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)
Q
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",""))
Q
ASKTO ;Ask for service when file link not defined in protocol file
D SERV^GMRCPS I 'GMRCDG S GMRCEND=1 Q
S GMRCSS=GMRCDG
Q
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")
Q
;
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
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HGMRCPR0 3790 printed Dec 13, 2024@01:46:48 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
