GMRCYP50 ;ISP/TDP - POST INSTALL FOR GMRC*3*50 ; 5/2/2006
;;3.0;CONSULT/REQUEST TRACKING;**50**;DEC 27, 1997;Build 8
Q
;
POST ; Start of Pre-init for patch GMRC*3*50
N GMRCTTL
K ^TMP("GMRCYP50",$J)
D BMES^XPDUTL("Starting Post-init...")
D BMES^XPDUTL(" Searching for Procedure Consults which have an Inter-Facility")
D MES^XPDUTL(" Consult as a Related Service.")
D MES^XPDUTL(" ")
D SEARCH
I GMRCTTL D MSG
I 'GMRCTTL D BMES^XPDUTL(" No invalid entries found.")
D BMES^XPDUTL("Post-init complete.")
Q
;
SEARCH ; Search RELATED SERVICES (#2) field of the GMRC PROCEDURE (#123.3) file
; for invalid IFC services.
N GMRCMSG,GMRCMSG1,GMRCPIEN,GMRCPRC,GMRCSIEN,GMRCSVC,X,XX,Y
S (GMRCPRC,GMRCTTL)=0
F S GMRCPRC=$O(^GMR(123.3,"B",GMRCPRC)) Q:GMRCPRC="" D
. S GMRCPIEN=""
. F S GMRCPIEN=$O(^GMR(123.3,"B",GMRCPRC,GMRCPIEN)) Q:GMRCPIEN="" D
.. S GMRCSIEN=0
.. F S GMRCSIEN=$O(^GMR(123.3,GMRCPIEN,2,"B",GMRCSIEN)) Q:GMRCSIEN="" D
... I '+$G(^GMR(123.5,+GMRCSIEN,"IFC")),'+$O(^GMR(123.5,+GMRCSIEN,"IFCS",0)) Q
... S GMRCSVC=$P($G(^GMR(123.5,GMRCSIEN,0)),U,1)
... I GMRCSVC="" S GMRCSVC="SERVICE UNKNOWN"
... S ^TMP("GMRCYP50",$J,GMRCPRC_" (#"_GMRCPIEN_")",GMRCSVC_" (#"_GMRCSIEN_")")=""
... K GMRCMSG
... S GMRCMSG="Related Service, "_GMRCSVC_" (IEN #"_GMRCSIEN_"), associated with Consult Procedure, "_GMRCPRC_" (IEN #"_GMRCPIEN_"), is an Inter-Facility Consult Service and must be removed or replaced with a service which is not an IFC!"
... S Y=0
... F X=1:1 S GMRCMSG1=$E(GMRCMSG,Y,Y+61) D Q:Y'<$L(GMRCMSG)
.... I $L(GMRCMSG1)<61 S Y=Y+61,GMRCMSG(X)=GMRCMSG1 Q
.... F XX=61:-1:1 D Q:$D(GMRCMSG(X))
..... I $E(GMRCMSG1,XX)'=" " Q
..... S Y=Y+1+XX I X>1 S Y=Y-1
..... S GMRCMSG(X)=$E(GMRCMSG1,1,XX)
... S X=""
... F S X=$O(GMRCMSG(X)) Q:X="" W !," "_$G(GMRCMSG(X))
... W !
... S GMRCTTL=GMRCTTL+1
;D MES^XPDUTL(" ")
D BMES^XPDUTL(" "_GMRCTTL_" total invalid Related Services.")
Q
;
MSG ; Send Mailman message to installer
N GMRCC,GMRCCNT,GMRCPARM,GMRCPRC,GMRCSVC,GMRCTXT,GMRCWHO
N XMDUZ,XMERR,XMSUB,XMTEXT,XMY,Y
S XMSUB="RELATED SERVICES ARE INVALID"
I DUZ="" N DUZ S DUZ=.5 ; if user not defined set to postmaster
S XMDUZ=DUZ,XMTEXT="GMRCTXT"
S GMRCPARM("FROM")="PATCH GMRC*3.0*50 POST-INIT"
S XMY(DUZ)="" ; send message to user
S GMRCC=0
S GMRCC=GMRCC+1,GMRCTXT(GMRCC)="This message has been sent by patch GMRC*3.0*50 at the completion of"
S GMRCC=GMRCC+1,GMRCTXT(GMRCC)="the post-init routine."
S GMRCC=GMRCC+1,GMRCTXT(GMRCC)=" "
S GMRCC=GMRCC+1,GMRCTXT(GMRCC)="This message was sent because Consult Procedure records were found which"
S GMRCC=GMRCC+1,GMRCTXT(GMRCC)="contained one or more Related Services which are setup as Inter-Facility"
S GMRCC=GMRCC+1,GMRCTXT(GMRCC)="Consults. These related services should be removed and replaced with"
S GMRCC=GMRCC+1,GMRCTXT(GMRCC)="non-IFC services to prevent possible problems in the Consult/Request"
S GMRCC=GMRCC+1,GMRCTXT(GMRCC)="Tracking package. The following information is provided to assist you"
S GMRCC=GMRCC+1,GMRCTXT(GMRCC)="in your cleanup efforts."
S GMRCC=GMRCC+1,GMRCTXT(GMRCC)=" "
S GMRCC=GMRCC+1,GMRCTXT(GMRCC)="PROCEDURE"
S GMRCC=GMRCC+1,GMRCTXT(GMRCC)=" RELATED SERVICE"
S GMRCC=GMRCC+1,GMRCTXT(GMRCC)="==========================================================================="
S GMRCC=GMRCC+1,GMRCTXT(GMRCC)=" "
S GMRCCNT=0,GMRCPRC=""
F S GMRCPRC=$O(^TMP("GMRCYP50",$J,GMRCPRC)) Q:GMRCPRC="" D
. S GMRCC=GMRCC+1,GMRCTXT(GMRCC)=GMRCPRC
. S GMRCSVC=""
. F S GMRCSVC=$O(^TMP("GMRCYP50",$J,GMRCPRC,GMRCSVC)) Q:GMRCSVC="" D
.. S GMRCC=GMRCC+1,GMRCTXT(GMRCC)=" "_GMRCSVC
.. S GMRCCNT=GMRCCNT+1
. S GMRCC=GMRCC+1,GMRCTXT(GMRCC)=" "
S GMRCC=GMRCC+1,GMRCTXT(GMRCC)=" "
S GMRCC=GMRCC+1,GMRCTXT(GMRCC)=" "
S GMRCC=GMRCC+1,GMRCTXT(GMRCC)="Total invalid Related Services: "_GMRCCNT
D SENDMSG^XMXAPI(XMDUZ,XMSUB,XMTEXT,.XMY,.GMRCPARM,"","")
S GMRCMSG(1)=" "
S GMRCMSG(2)="******************************************************************************"
S GMRCMSG(3)="** Message containing Procedure Consult records which have invalid **"
S GMRCMSG(4)="** Related Services was "_$S($D(XMERR):"not sent due to an error in the message set up. **",1:"sent to the "_$S(DUZ=.5:"postmaster. Please forward this **",1:"user. Please forward this **"))
I $D(XMERR) S GMRCMSG(5)="** Dumping message to screen. **"
I '$D(XMERR) S GMRCMSG(5)="** message to the appropriate staff, which includes the clinical **"
I '$D(XMERR) S GMRCMSG(6)="** coordinator, for further action. **"
S GMRCMSG($S($D(XMERR):6,1:7))="******************************************************************************"
D BMES^XPDUTL(.GMRCMSG)
I $D(XMERR) D BMES^XPDUTL(" "),BMES^XPDUTL(.GMRCTXT)
K ^TMP("GMRCYP50",$J)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HGMRCYP50 4990 printed Dec 13, 2024@01:47:58 Page 2
GMRCYP50 ;ISP/TDP - POST INSTALL FOR GMRC*3*50 ; 5/2/2006
+1 ;;3.0;CONSULT/REQUEST TRACKING;**50**;DEC 27, 1997;Build 8
+2 QUIT
+3 ;
POST ; Start of Pre-init for patch GMRC*3*50
+1 NEW GMRCTTL
+2 KILL ^TMP("GMRCYP50",$JOB)
+3 DO BMES^XPDUTL("Starting Post-init...")
+4 DO BMES^XPDUTL(" Searching for Procedure Consults which have an Inter-Facility")
+5 DO MES^XPDUTL(" Consult as a Related Service.")
+6 DO MES^XPDUTL(" ")
+7 DO SEARCH
+8 IF GMRCTTL
DO MSG
+9 IF 'GMRCTTL
DO BMES^XPDUTL(" No invalid entries found.")
+10 DO BMES^XPDUTL("Post-init complete.")
+11 QUIT
+12 ;
SEARCH ; Search RELATED SERVICES (#2) field of the GMRC PROCEDURE (#123.3) file
+1 ; for invalid IFC services.
+2 NEW GMRCMSG,GMRCMSG1,GMRCPIEN,GMRCPRC,GMRCSIEN,GMRCSVC,X,XX,Y
+3 SET (GMRCPRC,GMRCTTL)=0
+4 FOR
SET GMRCPRC=$ORDER(^GMR(123.3,"B",GMRCPRC))
if GMRCPRC=""
QUIT
Begin DoDot:1
+5 SET GMRCPIEN=""
+6 FOR
SET GMRCPIEN=$ORDER(^GMR(123.3,"B",GMRCPRC,GMRCPIEN))
if GMRCPIEN=""
QUIT
Begin DoDot:2
+7 SET GMRCSIEN=0
+8 FOR
SET GMRCSIEN=$ORDER(^GMR(123.3,GMRCPIEN,2,"B",GMRCSIEN))
if GMRCSIEN=""
QUIT
Begin DoDot:3
+9 IF '+$GET(^GMR(123.5,+GMRCSIEN,"IFC"))
IF '+$ORDER(^GMR(123.5,+GMRCSIEN,"IFCS",0))
QUIT
+10 SET GMRCSVC=$PIECE($GET(^GMR(123.5,GMRCSIEN,0)),U,1)
+11 IF GMRCSVC=""
SET GMRCSVC="SERVICE UNKNOWN"
+12 SET ^TMP("GMRCYP50",$JOB,GMRCPRC_" (#"_GMRCPIEN_")",GMRCSVC_" (#"_GMRCSIEN_")")=""
+13 KILL GMRCMSG
+14 SET GMRCMSG="Related Service, "_GMRCSVC_" (IEN #"_GMRCSIEN_"), associated with Consult Procedure, "_GMRCPRC_" (IEN #"_GMRCPIEN_"), is an Inter-Facility Consult Service and must be removed or replaced with a service which
is not an IFC!"
+15 SET Y=0
+16 FOR X=1:1
SET GMRCMSG1=$EXTRACT(GMRCMSG,Y,Y+61)
Begin DoDot:4
+17 IF $LENGTH(GMRCMSG1)<61
SET Y=Y+61
SET GMRCMSG(X)=GMRCMSG1
QUIT
+18 FOR XX=61:-1:1
Begin DoDot:5
+19 IF $EXTRACT(GMRCMSG1,XX)'=" "
QUIT
+20 SET Y=Y+1+XX
IF X>1
SET Y=Y-1
+21 SET GMRCMSG(X)=$EXTRACT(GMRCMSG1,1,XX)
End DoDot:5
if $DATA(GMRCMSG(X))
QUIT
End DoDot:4
if Y'<$LENGTH(GMRCMSG)
QUIT
+22 SET X=""
+23 FOR
SET X=$ORDER(GMRCMSG(X))
if X=""
QUIT
WRITE !," "_$GET(GMRCMSG(X))
+24 WRITE !
+25 SET GMRCTTL=GMRCTTL+1
End DoDot:3
End DoDot:2
End DoDot:1
+26 ;D MES^XPDUTL(" ")
+27 DO BMES^XPDUTL(" "_GMRCTTL_" total invalid Related Services.")
+28 QUIT
+29 ;
MSG ; Send Mailman message to installer
+1 NEW GMRCC,GMRCCNT,GMRCPARM,GMRCPRC,GMRCSVC,GMRCTXT,GMRCWHO
+2 NEW XMDUZ,XMERR,XMSUB,XMTEXT,XMY,Y
+3 SET XMSUB="RELATED SERVICES ARE INVALID"
+4 ; if user not defined set to postmaster
IF DUZ=""
NEW DUZ
SET DUZ=.5
+5 SET XMDUZ=DUZ
SET XMTEXT="GMRCTXT"
+6 SET GMRCPARM("FROM")="PATCH GMRC*3.0*50 POST-INIT"
+7 ; send message to user
SET XMY(DUZ)=""
+8 SET GMRCC=0
+9 SET GMRCC=GMRCC+1
SET GMRCTXT(GMRCC)="This message has been sent by patch GMRC*3.0*50 at the completion of"
+10 SET GMRCC=GMRCC+1
SET GMRCTXT(GMRCC)="the post-init routine."
+11 SET GMRCC=GMRCC+1
SET GMRCTXT(GMRCC)=" "
+12 SET GMRCC=GMRCC+1
SET GMRCTXT(GMRCC)="This message was sent because Consult Procedure records were found which"
+13 SET GMRCC=GMRCC+1
SET GMRCTXT(GMRCC)="contained one or more Related Services which are setup as Inter-Facility"
+14 SET GMRCC=GMRCC+1
SET GMRCTXT(GMRCC)="Consults. These related services should be removed and replaced with"
+15 SET GMRCC=GMRCC+1
SET GMRCTXT(GMRCC)="non-IFC services to prevent possible problems in the Consult/Request"
+16 SET GMRCC=GMRCC+1
SET GMRCTXT(GMRCC)="Tracking package. The following information is provided to assist you"
+17 SET GMRCC=GMRCC+1
SET GMRCTXT(GMRCC)="in your cleanup efforts."
+18 SET GMRCC=GMRCC+1
SET GMRCTXT(GMRCC)=" "
+19 SET GMRCC=GMRCC+1
SET GMRCTXT(GMRCC)="PROCEDURE"
+20 SET GMRCC=GMRCC+1
SET GMRCTXT(GMRCC)=" RELATED SERVICE"
+21 SET GMRCC=GMRCC+1
SET GMRCTXT(GMRCC)="==========================================================================="
+22 SET GMRCC=GMRCC+1
SET GMRCTXT(GMRCC)=" "
+23 SET GMRCCNT=0
SET GMRCPRC=""
+24 FOR
SET GMRCPRC=$ORDER(^TMP("GMRCYP50",$JOB,GMRCPRC))
if GMRCPRC=""
QUIT
Begin DoDot:1
+25 SET GMRCC=GMRCC+1
SET GMRCTXT(GMRCC)=GMRCPRC
+26 SET GMRCSVC=""
+27 FOR
SET GMRCSVC=$ORDER(^TMP("GMRCYP50",$JOB,GMRCPRC,GMRCSVC))
if GMRCSVC=""
QUIT
Begin DoDot:2
+28 SET GMRCC=GMRCC+1
SET GMRCTXT(GMRCC)=" "_GMRCSVC
+29 SET GMRCCNT=GMRCCNT+1
End DoDot:2
+30 SET GMRCC=GMRCC+1
SET GMRCTXT(GMRCC)=" "
End DoDot:1
+31 SET GMRCC=GMRCC+1
SET GMRCTXT(GMRCC)=" "
+32 SET GMRCC=GMRCC+1
SET GMRCTXT(GMRCC)=" "
+33 SET GMRCC=GMRCC+1
SET GMRCTXT(GMRCC)="Total invalid Related Services: "_GMRCCNT
+34 DO SENDMSG^XMXAPI(XMDUZ,XMSUB,XMTEXT,.XMY,.GMRCPARM,"","")
+35 SET GMRCMSG(1)=" "
+36 SET GMRCMSG(2)="******************************************************************************"
+37 SET GMRCMSG(3)="** Message containing Procedure Consult records which have invalid **"
+38 SET GMRCMSG(4)="** Related Services was "_$SELECT($DATA(XMERR):"not sent due to an error in the message set up. **",1:"sent to the "_$SELECT(DUZ=.5:"postmaster. Please forward this **",1:"user. Please forward this *
*"))
+39 IF $DATA(XMERR)
SET GMRCMSG(5)="** Dumping message to screen. **"
+40 IF '$DATA(XMERR)
SET GMRCMSG(5)="** message to the appropriate staff, which includes the clinical **"
+41 IF '$DATA(XMERR)
SET GMRCMSG(6)="** coordinator, for further action. **"
+42 SET GMRCMSG($SELECT($DATA(XMERR):6,1:7))="******************************************************************************"
+43 DO BMES^XPDUTL(.GMRCMSG)
+44 IF $DATA(XMERR)
DO BMES^XPDUTL(" ")
DO BMES^XPDUTL(.GMRCTXT)
+45 KILL ^TMP("GMRCYP50",$JOB)
+46 QUIT
