Routine: GMRCPR0

GMRCPR0 ; SLC/DLT - Data Entry Promptint actions ;9/8/98  03:59

 ;;3.0;CONSULT/REQUEST TRACKING;**1,5,12,15**;DEC 27, 1997

 ; This routine invokes IA #2982

ASK ;ASK FOR TO, PROCEDURE,URGENCY, AND PLACE OF CONSULT

 I $D(GMRCPR),'$D(GMRCPRI) S GMRCPRI=+GMRCPR_";ORD(101,",GMRCORSV=$S(+^ORD(101,+GMRCPR,5):+^(5),1:GMRCSS),GMRCSRVC=$P(^GMR(123.5,GMRCORSV,0),"^",1) K GMRCORSV

 I $S('$D(GMRCPR):1,GMRCPR="":1,1:0) D PROC Q:GMRCEND  S GMRCORSV=^ORD(101,+GMRCPRI,5),GMRCORSV=+GMRCORSV,GMRCSRVC=$P(^GMR(123.5,GMRCORSV,0),"^",1) K GMRCORSV

 I '$D(GMRCSRVC) S GMRCSRVC=GMRCSSNM

ASK1 I $L(GMRCWARD) S GMRCIOPT="I"

 E  S GMRCIOPT="O"

 S DIR(0)="123,14",DIR("A")="Service rendered on (I)npatient or (O)utpatient basis?",DIR("B")=GMRCIOPT D ^DIR K DIR I $D(DTOUT)!($D(DUOUT))!($D(DIROUT)) S GMRCEND=1 K DTOUT,DUOUT,DIROUT Q

 S GMRCIOPT=Y

 I GMRCIOPT="I" S X="GMRCURGENCYM REQ - INPATIENT"

 E  S X="GMRCURGENCYM - OUTPATIENT"

 S DIC=101,DIC(0)="X" D ^DIC K DIC Q:Y<0

 S XQORM("??")="D URGHELP^GMRCPH",XQORM=+Y_";ORD(101,",XQORM(0)="1A\"

 S XQORM("A")="URGENCY: ",XQORM("NO^^")=""

 S GMRCURG1=$G(^DISV(DUZ,"XQORM",XQORM,1)) I '$L(GMRCURG1) K GMRCURG1

 I $D(GMRCURG1) S GMRCURG1=$$UP^XLFSTR(GMRCURG1) I $O(^XUTL("XQORM",XQORM,"B",GMRCURG1,0)) S XQORM("B")=^DISV(DUZ,"XQORM",XQORM,1)

 F  D  Q:Y  I $D(GMRCEND),GMRCEND Q

 .K GMRCURG1

 .D EN^XQORM I X="^"!($D(DIROUT)) S GMRCEND=1 K DIROUT,DTOUT,DUOUT Q

 .I Y<0 S GMRCMSG="The URGENCY is a required response." D EXAC^GMRCADC(GMRCMSG) K GMRCMSG

.Q

 I $D(GMRCEND),GMRCEND Q

 I $D(Y(1)) S GMRCURG=$P(Y(1),"^",3),GMRCURGI=$P(Y(1),"^",2)

 I GMRCIOPT="I" S X="GMRCPLACEM - INPATIENT"

 E  S X="GMRCPLACEM - OUTPATIENT"

 S DIC=101,DIC(0)="X" D ^DIC Q:Y<0

 K XQORM S XQORM("??")="D PLHELP^GMRCPH",XQORM=+Y_";ORD(101,",XQORM(0)="1A\"

 S XQORM("A")="PLACE OF CONSULTATION: "

 S XQORM("B")=$P($G(^XUTL("XQORM",XQORM,1.1,0)),U,3),XQORM("NO^^")=""

 D EN^XQORM I X="^"!($D(DIROUT)) K XQORM,DIROUT,DTOUT,DUOUT S GMRCEND=1 Q

 I Y<0 D  Q:+$G(GMRCEND)

 .W $C(7),!!,"  The PLACE OF CONSULTATION is a required response!",!

 .D EN^XQORM K XQORM I X="^"!($D(DIROUT))!(Y<1) K DIROUT,DTOUT,DUOUT S GMRCEND=1 Q

 K XQORM I $D(Y(1)) S GMRCPL=$P(Y(1),"^",3),GMRCPLI=$P(Y(1),"^",2)

TO ;Get Service from File Link field

 S GMRCSS=$P($G(^ORD(101,+GMRCPRI,5)),"^")

 I '+GMRCSS D ASKTO Q:GMRCEND

 I +GMRCSS S GMRCSS=+GMRCSS,GMRCSSNM=$P($G(^GMR(123.5,GMRCSS,.1)),"^") I '$L(GMRCSSNM) S GMRCSSNM=$P($G(^GMR(123.5,GMRCSS,0)),"^",1)

 S ORTO=$O(^ORD(100.98,"B","CONSULTS",""))

ASKTO ;Ask for service when file link not defined in protocol file

 D SERV^GMRCPS I 'GMRCDG S GMRCEND=1 Q

 S GMRCSS=GMRCDG

PROC ;Use XQORM to select procedure

 S GMRCEND=0 N XQORM

 S DIC=101,X="GMRCRM REQUEST TYPES",DIC(0)="X" D ^DIC Q:Y<0

 S XQORM("??")="D PROCHELP^GMRCPH",XQORM=+Y_";ORD(101,",XQORM(0)="1A\",XQORM("A")="Select PROCEDURE: ",XQORM("NO^^")="" I $D(GMRCPR),$L(GMRCPR) S XQORM("B")=GMRCPR

 D EN^XQORM K XQORM I X="^"!('$L(X))!($D(DIROUT)) S (GMRCQUT,GMRCEND)=1 K DIROUT,DTOUT,DUOUT Q

 I $D(Y(1)) S (GMRCVP,GMRCPRI)=$P(Y(1),"^",2)_";ORD(101,",GMRCPR=$S($D(^ORD(101,$P(Y(1),"^",2),.1)):$P(^(.1),"^"),1:"") I '$L(GMRCPR) S GMRCPR=$P(Y(1),"^",3)

 S X=$S($D(^ORD(101,+GMRCPRI,20)):$P(^(20)," D ",1),1:"") X:X]"" X S GMRCEN=$S($G(GMRCEN)]"":GMRCEN,1:""),GMRCTYPE=$S(GMRCEN="R":"GMRCOR REQUEST",1:"GMRCOR CONSULT")

GETSVC(SLIST,PROC) ;Get the services that process a procedure type

 N SVC,SCNT

 I '+$G(PROC) Q

 S SCNT=0,SLIST=SCNT

 S SVC=0

 F  S SVC=$O(^GMR(123.3,+PROC,2,"B",SVC)) Q:'SVC  D

 . Q:'$D(^GMR(123.5,+SVC,0))

 . Q:$P(^GMR(123.5,+SVC,0),U,2)=1  ;no groupers

 . Q:$P(^GMR(123.5,+SVC,0),U,2)=9  ;no disabled services

 . S SCNT=SCNT+1

 . S SLIST(SCNT)=SVC_"^"_$P($G(^GMR(123.5,SVC,0)),U,1)

. Q

 S SLIST=SCNT

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HGMRCPR0   3790     printed  Feb 18, 2025@23:13:11                                                                                                                                                                                                     Page 2

GMRCPR0   ; SLC/DLT - Data Entry Promptint actions ;9/8/98  03:59

 +1       ;;3.0;CONSULT/REQUEST TRACKING;**1,5,12,15**;DEC 27, 1997

 +2       ;

 +3       ; This routine invokes IA #2982

 +4       ;

ASK       ;ASK FOR TO, PROCEDURE,URGENCY, AND PLACE OF CONSULT

 +1        IF $DATA(GMRCPR)

               IF '$DATA(GMRCPRI)

                   SET GMRCPRI=+GMRCPR_";ORD(101,"

                   SET GMRCORSV=$SELECT(+^ORD(101,+GMRCPR,5):+^(5),1:GMRCSS)

                   SET GMRCSRVC=$PIECE(^GMR(123.5,GMRCORSV,0),"^",1)

                   KILL GMRCORSV

 +2        IF $SELECT('$DATA(GMRCPR):1,GMRCPR="":1,1:0)

               DO PROC

               if GMRCEND

                   QUIT

               SET GMRCORSV=^ORD(101,+GMRCPRI,5)

               SET GMRCORSV=+GMRCORSV

               SET GMRCSRVC=$PIECE(^GMR(123.5,GMRCORSV,0),"^",1)

               KILL GMRCORSV

 +3        IF '$DATA(GMRCSRVC)

               SET GMRCSRVC=GMRCSSNM

ASK1       IF $LENGTH(GMRCWARD)

               SET GMRCIOPT="I"

 +1       IF '$TEST

               SET GMRCIOPT="O"

 +2        SET DIR(0)="123,14"

           SET DIR("A")="Service rendered on (I)npatient or (O)utpatient basis?"

           SET DIR("B")=GMRCIOPT

           DO ^DIR

           KILL DIR

           IF $DATA(DTOUT)!($DATA(DUOUT))!($DATA(DIROUT))

               SET GMRCEND=1

               KILL DTOUT,DUOUT,DIROUT

               QUIT

 +3        SET GMRCIOPT=Y

 +4        IF GMRCIOPT="I"

               SET X="GMRCURGENCYM REQ - INPATIENT"

 +5       IF '$TEST

               SET X="GMRCURGENCYM - OUTPATIENT"

 +6        SET DIC=101

           SET DIC(0)="X"

           DO ^DIC

           KILL DIC

           if Y<0

               QUIT

 +7        SET XQORM("??")="D URGHELP^GMRCPH"

           SET XQORM=+Y_";ORD(101,"

           SET XQORM(0)="1A\"

 +8        SET XQORM("A")="URGENCY: "

           SET XQORM("NO^^")=""

 +9        SET GMRCURG1=$GET(^DISV(DUZ,"XQORM",XQORM,1))

           IF '$LENGTH(GMRCURG1)

               KILL GMRCURG1

 +10       IF $DATA(GMRCURG1)

               SET GMRCURG1=$$UP^XLFSTR(GMRCURG1)

               IF $ORDER(^XUTL("XQORM",XQORM,"B",GMRCURG1,0))

                   SET XQORM("B")=^DISV(DUZ,"XQORM",XQORM,1)

 +11       FOR

               Begin DoDot:1

 +12               KILL GMRCURG1

 +13               DO EN^XQORM

                   IF X="^"!($DATA(DIROUT))

                       SET GMRCEND=1

                       KILL DIROUT,DTOUT,DUOUT

                       QUIT

 +14               IF Y<0

                       SET GMRCMSG="The URGENCY is a required response."

                       DO EXAC^GMRCADC(GMRCMSG)

                       KILL GMRCMSG

 +15               QUIT

               End DoDot:1

               if Y

                   QUIT

               IF $DATA(GMRCEND)

                   IF GMRCEND

                       QUIT

 +16       IF $DATA(GMRCEND)

               IF GMRCEND

                   QUIT

 +17       IF $DATA(Y(1))

               SET GMRCURG=$PIECE(Y(1),"^",3)

               SET GMRCURGI=$PIECE(Y(1),"^",2)

 +18       IF GMRCIOPT="I"

               SET X="GMRCPLACEM - INPATIENT"

 +19      IF '$TEST

               SET X="GMRCPLACEM - OUTPATIENT"

 +20       SET DIC=101

           SET DIC(0)="X"

           DO ^DIC

           if Y<0

               QUIT

 +21       KILL XQORM

           SET XQORM("??")="D PLHELP^GMRCPH"

           SET XQORM=+Y_";ORD(101,"

           SET XQORM(0)="1A\"

 +22       SET XQORM("A")="PLACE OF CONSULTATION: "

 +23       SET XQORM("B")=$PIECE($GET(^XUTL("XQORM",XQORM,1.1,0)),U,3)

           SET XQORM("NO^^")=""

 +24       DO EN^XQORM

           IF X="^"!($DATA(DIROUT))

               KILL XQORM,DIROUT,DTOUT,DUOUT

               SET GMRCEND=1

               QUIT

 +25       IF Y<0

               Begin DoDot:1

 +26               WRITE $CHAR(7),!!,"  The PLACE OF CONSULTATION is a required response!",!

 +27               DO EN^XQORM

                   KILL XQORM

                   IF X="^"!($DATA(DIROUT))!(Y<1)

                       KILL DIROUT,DTOUT,DUOUT

                       SET GMRCEND=1

                       QUIT

               End DoDot:1

               if +$GET(GMRCEND)

                   QUIT

 +28       KILL XQORM

           IF $DATA(Y(1))

               SET GMRCPL=$PIECE(Y(1),"^",3)

               SET GMRCPLI=$PIECE(Y(1),"^",2)

 +29       QUIT

TO        ;Get Service from File Link field

 +1        SET GMRCSS=$PIECE($GET(^ORD(101,+GMRCPRI,5)),"^")

 +2        IF '+GMRCSS

               DO ASKTO

               if GMRCEND

                   QUIT

 +3        IF +GMRCSS

               SET GMRCSS=+GMRCSS

               SET GMRCSSNM=$PIECE($GET(^GMR(123.5,GMRCSS,.1)),"^")

               IF '$LENGTH(GMRCSSNM)

                   SET GMRCSSNM=$PIECE($GET(^GMR(123.5,GMRCSS,0)),"^",1)

 +4        SET ORTO=$ORDER(^ORD(100.98,"B","CONSULTS",""))

 +5        QUIT

ASKTO     ;Ask for service when file link not defined in protocol file

 +1        DO SERV^GMRCPS

           IF 'GMRCDG

               SET GMRCEND=1

               QUIT

 +2        SET GMRCSS=GMRCDG

 +3        QUIT

PROC      ;Use XQORM to select procedure

 +1        SET GMRCEND=0

           NEW XQORM

 +2        SET DIC=101

           SET X="GMRCRM REQUEST TYPES"

           SET DIC(0)="X"

           DO ^DIC

           if Y<0

               QUIT

 +3        SET XQORM("??")="D PROCHELP^GMRCPH"

           SET XQORM=+Y_";ORD(101,"

           SET XQORM(0)="1A\"

           SET XQORM("A")="Select PROCEDURE: "

           SET XQORM("NO^^")=""

           IF $DATA(GMRCPR)

               IF $LENGTH(GMRCPR)

                   SET XQORM("B")=GMRCPR

 +4        DO EN^XQORM

           KILL XQORM

           IF X="^"!('$LENGTH(X))!($DATA(DIROUT))

               SET (GMRCQUT,GMRCEND)=1

               KILL DIROUT,DTOUT,DUOUT

               QUIT

 +5        IF $DATA(Y(1))

               SET (GMRCVP,GMRCPRI)=$PIECE(Y(1),"^",2)_";ORD(101,"

               SET GMRCPR=$SELECT($DATA(^ORD(101,$PIECE(Y(1),"^",2),.1)):$PIECE(^(.1),"^"),1:"")

               IF '$LENGTH(GMRCPR)

                   SET GMRCPR=$PIECE(Y(1),"^",3)

 +6        SET X=$SELECT($DATA(^ORD(101,+GMRCPRI,20)):$PIECE(^(20)," D ",1),1:"")

           if X]""

               XECUTE X

           SET GMRCEN=$SELECT($GET(GMRCEN)]"":GMRCEN,1:"")

           SET GMRCTYPE=$SELECT(GMRCEN="R":"GMRCOR REQUEST",1:"GMRCOR CONSULT")

 +7        QUIT

 +8       ;

GETSVC(SLIST,PROC) ;Get the services that process a procedure type

 +1        NEW SVC,SCNT

 +2        IF '+$GET(PROC)

               QUIT

 +3        SET SCNT=0

           SET SLIST=SCNT

 +4        SET SVC=0

 +5        FOR

               SET SVC=$ORDER(^GMR(123.3,+PROC,2,"B",SVC))

               if 'SVC

                   QUIT

               Begin DoDot:1

 +6                if '$DATA(^GMR(123.5,+SVC,0))

                       QUIT

 +7       ;no groupers

                   if $PIECE(^GMR(123.5,+SVC,0),U,2)=1

                       QUIT

 +8       ;no disabled services

                   if $PIECE(^GMR(123.5,+SVC,0),U,2)=9

                       QUIT

 +9                SET SCNT=SCNT+1

 +10               SET SLIST(SCNT)=SVC_"^"_$PIECE($GET(^GMR(123.5,SVC,0)),U,1)

 +11               QUIT

               End DoDot:1

 +12       SET SLIST=SCNT

 +13       QUIT

GMRCPR0.m