GMRCEDT2 ;SLC/JFR,DCM - RESUBMIT A CANCELLED CONSULT ;10/09/15 13:08
;;3.0;CONSULT/REQUEST TRACKING;**1,5,12,15,22,33,66,46,73,85**;DEC 27, 1997;Build 3
;
;ICRs in use: #2053 (DIE), #2056 (GET1^DIQ), #872 (ORD(101))
;patch 85 removed call to $$PDOK^GMRCEDT4
;
EN(GMRCO,COMNO) ;entry point into the routine
;COMNO=CMDA from ^GMRCEDT2=comments array IEN from ^GMR(123,IEN,40,
;GMRCO=IEN of the consult from file 123
I $S($P(^GMR(123,GMRCO,0),"^",12)'=13:1,$D(GMRCRSUB):1,1:0) D Q
.S GMRCMSG="*** Consult Has Already Been Resubmitted ***"
.S GMRCMSG(1)="*** No Further Action Is Required Or Allowed ***"
.D EXAC^GMRCADC(.GMRCMSG)
.S:'$D(GMRCRSUB) GMRCRSUB=1
.Q
N MSG S MSG=$$EDRESOK(GMRCO)
I '+MSG D EXAC^GMRCADC($P(MSG,U,2)) Q
I '$D(GMRCGUIF) W !,"Resubmitting Consult ... One moment please ..."
K ^TMP("GMRCSUB",$J) S ^TMP("GMRCSUB",$J)=0
I $D(GMRCEDT(1)) S ^TMP("GMRCSUB",$J,1)="GMRCSS^"_+GMRCEDT(1)
I $D(GMRCED(1)) D
. I $P(GMRCED(1),U)=$P(^GMR(123,+GMRCO,0),U,8) K GMRCED(1) Q
. S ^TMP("GMRCSUB",$J,2)="GMRCPROC^"_+GMRCED(1)_";GMR(123.3,"
I $D(GMRCED(2)) D
. I $P(GMRCED(2),U)=$P(^GMR(123,+GMRCO,0),U,18) K GMRCED(2) Q
. S ^TMP("GMRCSUB",$J,3)="GMRCION^"_$P(GMRCED(2),U)
I $D(GMRCED(3)) D
. I $P(GMRCED(3),U)=$P(^GMR(123,+GMRCO,0),U,9) K GMRCED(3) Q
. S ^TMP("GMRCSUB",$J,4)="GMRCURG^"_$P(GMRCED(3),U)
I $D(GMRCED(4)) D
. I $P(GMRCED(4),U)=$P(^GMR(123,+GMRCO,0),U,10) K GMRCED(4) Q
. S ^TMP("GMRCSUB",$J,5)="GMRCPL^"_$P(GMRCED(4),U)
I $D(GMRCED(5)) D ;wat/66 add early date
. I $P(GMRCED(5),U)=$P(^GMR(123,+GMRCO,0),U,24) K GMRCED(5) Q
. S ^TMP("GMRCSUB",$J,6)="GMRCERDT^"_$P(GMRCED(5),U)
I $D(GMRCED(6)) D
. I $P(GMRCED(6),U)=$P(^GMR(123,+GMRCO,0),U,11) K GMRCED(6) Q
. I '$L($P(GMRCED(6),U)) S $P(GMRCED(6),U)="@"
. S ^TMP("GMRCSUB",$J,7)="GMRCATN^"_$P(GMRCED(6),U)
I $D(GMRCED(7)) D
. I GMRCED(7)=$G(^GMR(123,+GMRCO,30)) K GMRCED(7) Q
. I $P(GMRCED(7),U)_" ("_$P(GMRCED(7),U,2)_")"=$G(^GMR(123,GMRCO,30)) K GMRCED(7) Q
. I '$L($P(GMRCED(7),U)) S $P(GMRCED(7),U,1,2)="@"
. S ^TMP("GMRCSUB",$J,8)="GMRCDIAG^"_GMRCED(7)
I $D(^TMP("GMRCED",$J,20)) S ^TMP("GMRCSUB",$J,20)="GMRCRFQ^" D
. N ND S ND=0
. F S ND=$O(^TMP("GMRCED",$J,20,ND)) Q:'ND D
.. S ^TMP("GMRCSUB",$J,20,ND)=^TMP("GMRCED",$J,20,ND,0)
I $D(^TMP("GMRCED",$J,40)) S ^TMP("GMRCSUB",$J,40)="COMMENT^" D
. N ND S ND=0
. F S ND=$O(^TMP("GMRCED",$J,40,ND)) Q:'ND D
.. S ^TMP("GMRCSUB",$J,40,ND)=^TMP("GMRCED",$J,40,ND,0)
D FILE^GMRCGUIC(+GMRCO,$NAME(^TMP("GMRCSUB",$J)),1)
N GMRCADUZ S GMRCADUZ=""
S DFN=$P(^GMR(123,+GMRCO,0),"^",2),GMRCPROV=$P(^(0),"^",14)
S GMRCTYPE=$P(^GMR(123,+GMRCO,0),U,17),GMRCTRLC="XX",VISIT="",RMBED=""
S DIE="^GMR(123,",DA=+GMRCO,DR="8////^S X=5;9////^S X=11" D ^DIE
K DIE,DA,DR
S GMRCRSUB=1
S GMRCURG=$P(^GMR(123,+GMRCO,0),"^",9)
I +$P(^GMR(123,+GMRCO,0),"^",11) S GMRCADUZ($P(^(0),"^",11))=""
S GMRCSVC=$P(^GMR(123,+GMRCO,0),"^",5)
I +GMRCSVC D
. D EN^GMRCT(GMRCSVC)
S GMRCORTX="Resubmitted consult "_$$ORTX^GMRCAU(+GMRCO)_$S(+GMRCURG:" ("_$P(^ORD(101,+GMRCURG,0),"^",2)_")",1:"")
K GMRCFL,GMRCPROV,GMRCTYPE,GMRCTRLC,VISIT,RMBED,GMRCOM,GMRCURG
K GMRCSVC,GMRCORTX
Q
EDRESOK(GMRCDA) ;check cslt or proc to see if still resubmittable
; if procedure is inactive or no services, not resubmittable
; if service is grouper or disabled, not resubmittable
N MSG,GMRC
Q:'$D(^GMR(123,+$G(GMRCDA),0)) "0^Invalid Consult Number"
I $P($G(^GMR(123,+GMRCDA,12)),U,5)="F" D Q MSG
. S MSG="0^This inter-facility cconsult may only be resubmitted by the"
. S MSG=MSG_" ordering facility."
S GMRC(0)=^GMR(123,+GMRCDA,0)
I '$P(GMRC(0),U,8) D Q MSG
. I "19"[+$P(^GMR(123.5,+$P(GMRC(0),U,5),0),U,2) D Q
.. S MSG="0^The service for this Consult is no longer orderable."
. S MSG=1
S MSG=1
I "19"[+$P(^GMR(123.5,+$P(GMRC(0),U,5),0),U,2) S MSG=0
I '$L($$GET1^DIQ(123.3,+$P(GMRC(0),U,8),.01)) S MSG=0
I +$$GET1^DIQ(123.3,+$P(GMRC(0),U,8),.02) S MSG=0
I '$D(^GMR(123.3,+$P(GMRC(0),U,8),2,"B",+$P(GMRC(0),U,5))) S MSG=0
I MSG=0 D
. S MSG=MSG_"^This procedure may no longer be ordered or the service "
. S MSG=MSG_"may no longer perform it."
Q MSG
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HGMRCEDT2 4198 printed Dec 13, 2024@01:45:33 Page 2
GMRCEDT2 ;SLC/JFR,DCM - RESUBMIT A CANCELLED CONSULT ;10/09/15 13:08
+1 ;;3.0;CONSULT/REQUEST TRACKING;**1,5,12,15,22,33,66,46,73,85**;DEC 27, 1997;Build 3
+2 ;
+3 ;ICRs in use: #2053 (DIE), #2056 (GET1^DIQ), #872 (ORD(101))
+4 ;patch 85 removed call to $$PDOK^GMRCEDT4
+5 ;
EN(GMRCO,COMNO) ;entry point into the routine
+1 ;COMNO=CMDA from ^GMRCEDT2=comments array IEN from ^GMR(123,IEN,40,
+2 ;GMRCO=IEN of the consult from file 123
+3 IF $SELECT($PIECE(^GMR(123,GMRCO,0),"^",12)'=13:1,$DATA(GMRCRSUB):1,1:0)
Begin DoDot:1
+4 SET GMRCMSG="*** Consult Has Already Been Resubmitted ***"
+5 SET GMRCMSG(1)="*** No Further Action Is Required Or Allowed ***"
+6 DO EXAC^GMRCADC(.GMRCMSG)
+7 if '$DATA(GMRCRSUB)
SET GMRCRSUB=1
+8 QUIT
End DoDot:1
QUIT
+9 NEW MSG
SET MSG=$$EDRESOK(GMRCO)
+10 IF '+MSG
DO EXAC^GMRCADC($PIECE(MSG,U,2))
QUIT
+11 IF '$DATA(GMRCGUIF)
WRITE !,"Resubmitting Consult ... One moment please ..."
+12 KILL ^TMP("GMRCSUB",$JOB)
SET ^TMP("GMRCSUB",$JOB)=0
+13 IF $DATA(GMRCEDT(1))
SET ^TMP("GMRCSUB",$JOB,1)="GMRCSS^"_+GMRCEDT(1)
+14 IF $DATA(GMRCED(1))
Begin DoDot:1
+15 IF $PIECE(GMRCED(1),U)=$PIECE(^GMR(123,+GMRCO,0),U,8)
KILL GMRCED(1)
QUIT
+16 SET ^TMP("GMRCSUB",$JOB,2)="GMRCPROC^"_+GMRCED(1)_";GMR(123.3,"
End DoDot:1
+17 IF $DATA(GMRCED(2))
Begin DoDot:1
+18 IF $PIECE(GMRCED(2),U)=$PIECE(^GMR(123,+GMRCO,0),U,18)
KILL GMRCED(2)
QUIT
+19 SET ^TMP("GMRCSUB",$JOB,3)="GMRCION^"_$PIECE(GMRCED(2),U)
End DoDot:1
+20 IF $DATA(GMRCED(3))
Begin DoDot:1
+21 IF $PIECE(GMRCED(3),U)=$PIECE(^GMR(123,+GMRCO,0),U,9)
KILL GMRCED(3)
QUIT
+22 SET ^TMP("GMRCSUB",$JOB,4)="GMRCURG^"_$PIECE(GMRCED(3),U)
End DoDot:1
+23 IF $DATA(GMRCED(4))
Begin DoDot:1
+24 IF $PIECE(GMRCED(4),U)=$PIECE(^GMR(123,+GMRCO,0),U,10)
KILL GMRCED(4)
QUIT
+25 SET ^TMP("GMRCSUB",$JOB,5)="GMRCPL^"_$PIECE(GMRCED(4),U)
End DoDot:1
+26 ;wat/66 add early date
IF $DATA(GMRCED(5))
Begin DoDot:1
+27 IF $PIECE(GMRCED(5),U)=$PIECE(^GMR(123,+GMRCO,0),U,24)
KILL GMRCED(5)
QUIT
+28 SET ^TMP("GMRCSUB",$JOB,6)="GMRCERDT^"_$PIECE(GMRCED(5),U)
End DoDot:1
+29 IF $DATA(GMRCED(6))
Begin DoDot:1
+30 IF $PIECE(GMRCED(6),U)=$PIECE(^GMR(123,+GMRCO,0),U,11)
KILL GMRCED(6)
QUIT
+31 IF '$LENGTH($PIECE(GMRCED(6),U))
SET $PIECE(GMRCED(6),U)="@"
+32 SET ^TMP("GMRCSUB",$JOB,7)="GMRCATN^"_$PIECE(GMRCED(6),U)
End DoDot:1
+33 IF $DATA(GMRCED(7))
Begin DoDot:1
+34 IF GMRCED(7)=$GET(^GMR(123,+GMRCO,30))
KILL GMRCED(7)
QUIT
+35 IF $PIECE(GMRCED(7),U)_" ("_$PIECE(GMRCED(7),U,2)_")"=$GET(^GMR(123,GMRCO,30))
KILL GMRCED(7)
QUIT
+36 IF '$LENGTH($PIECE(GMRCED(7),U))
SET $PIECE(GMRCED(7),U,1,2)="@"
+37 SET ^TMP("GMRCSUB",$JOB,8)="GMRCDIAG^"_GMRCED(7)
End DoDot:1
+38 IF $DATA(^TMP("GMRCED",$JOB,20))
SET ^TMP("GMRCSUB",$JOB,20)="GMRCRFQ^"
Begin DoDot:1
+39 NEW ND
SET ND=0
+40 FOR
SET ND=$ORDER(^TMP("GMRCED",$JOB,20,ND))
if 'ND
QUIT
Begin DoDot:2
+41 SET ^TMP("GMRCSUB",$JOB,20,ND)=^TMP("GMRCED",$JOB,20,ND,0)
End DoDot:2
End DoDot:1
+42 IF $DATA(^TMP("GMRCED",$JOB,40))
SET ^TMP("GMRCSUB",$JOB,40)="COMMENT^"
Begin DoDot:1
+43 NEW ND
SET ND=0
+44 FOR
SET ND=$ORDER(^TMP("GMRCED",$JOB,40,ND))
if 'ND
QUIT
Begin DoDot:2
+45 SET ^TMP("GMRCSUB",$JOB,40,ND)=^TMP("GMRCED",$JOB,40,ND,0)
End DoDot:2
End DoDot:1
+46 DO FILE^GMRCGUIC(+GMRCO,$NAME(^TMP("GMRCSUB",$JOB)),1)
+47 NEW GMRCADUZ
SET GMRCADUZ=""
+48 SET DFN=$PIECE(^GMR(123,+GMRCO,0),"^",2)
SET GMRCPROV=$PIECE(^(0),"^",14)
+49 SET GMRCTYPE=$PIECE(^GMR(123,+GMRCO,0),U,17)
SET GMRCTRLC="XX"
SET VISIT=""
SET RMBED=""
+50 SET DIE="^GMR(123,"
SET DA=+GMRCO
SET DR="8////^S X=5;9////^S X=11"
DO ^DIE
+51 KILL DIE,DA,DR
+52 SET GMRCRSUB=1
+53 SET GMRCURG=$PIECE(^GMR(123,+GMRCO,0),"^",9)
+54 IF +$PIECE(^GMR(123,+GMRCO,0),"^",11)
SET GMRCADUZ($PIECE(^(0),"^",11))=""
+55 SET GMRCSVC=$PIECE(^GMR(123,+GMRCO,0),"^",5)
+56 IF +GMRCSVC
Begin DoDot:1
+57 DO EN^GMRCT(GMRCSVC)
End DoDot:1
+58 SET GMRCORTX="Resubmitted consult "_$$ORTX^GMRCAU(+GMRCO)_$SELECT(+GMRCURG:" ("_$PIECE(^ORD(101,+GMRCURG,0),"^",2)_")",1:"")
+59 KILL GMRCFL,GMRCPROV,GMRCTYPE,GMRCTRLC,VISIT,RMBED,GMRCOM,GMRCURG
+60 KILL GMRCSVC,GMRCORTX
+61 QUIT
EDRESOK(GMRCDA) ;check cslt or proc to see if still resubmittable
+1 ; if procedure is inactive or no services, not resubmittable
+2 ; if service is grouper or disabled, not resubmittable
+3 NEW MSG,GMRC
+4 if '$DATA(^GMR(123,+$GET(GMRCDA),0))
QUIT "0^Invalid Consult Number"
+5 IF $PIECE($GET(^GMR(123,+GMRCDA,12)),U,5)="F"
Begin DoDot:1
+6 SET MSG="0^This inter-facility cconsult may only be resubmitted by the"
+7 SET MSG=MSG_" ordering facility."
End DoDot:1
QUIT MSG
+8 SET GMRC(0)=^GMR(123,+GMRCDA,0)
+9 IF '$PIECE(GMRC(0),U,8)
Begin DoDot:1
+10 IF "19"[+$PIECE(^GMR(123.5,+$PIECE(GMRC(0),U,5),0),U,2)
Begin DoDot:2
+11 SET MSG="0^The service for this Consult is no longer orderable."
End DoDot:2
QUIT
+12 SET MSG=1
End DoDot:1
QUIT MSG
+13 SET MSG=1
+14 IF "19"[+$PIECE(^GMR(123.5,+$PIECE(GMRC(0),U,5),0),U,2)
SET MSG=0
+15 IF '$LENGTH($$GET1^DIQ(123.3,+$PIECE(GMRC(0),U,8),.01))
SET MSG=0
+16 IF +$$GET1^DIQ(123.3,+$PIECE(GMRC(0),U,8),.02)
SET MSG=0
+17 IF '$DATA(^GMR(123.3,+$PIECE(GMRC(0),U,8),2,"B",+$PIECE(GMRC(0),U,5)))
SET MSG=0
+18 IF MSG=0
Begin DoDot:1
+19 SET MSG=MSG_"^This procedure may no longer be ordered or the service "
+20 SET MSG=MSG_"may no longer perform it."
End DoDot:1
+21 QUIT MSG
