GMRCSTSU ;SLC/DLT - Change status based on current order status ;7/16/98 03:43
;;3.0;CONSULT/REQUEST TRACKING;**4**;DEC 27, 1997
CPRSUPD(GMRCO) ;Update CPRS order with new status
;GMRCO=IEN from file 123
Q
N DFN,CTRLCODE,GMRCSTS,GMRCPROV,GMRCORFN,ORSTS,ORIFN
S GMRCSTS=$P(^GMR(123,+GMRCO,0),"^",12),GMRCORFN=$P(^(0),"^",3),DFN=$P(^(0),"^",2),GMRCPROV=$P(^(0),"^",14)
;S CTRLCODE=$S(GMRCSTS=5:"ZU",GMRCSTS=6:"ZU",1:"ZR")
;S DIE="^GMR(123,",DA=GMRCO,DR=".03////^S X=""@"""
;D ^DIE
K GMRCSTS,DIE,DA,DR
Q
;D EN^GMRCHL7(DFN,+GMRCO,"","",CTRLCODE,GMRCPROV,"","") ;Send CPRS an HL-7 message about status of purge - can/can't purge record
Q
END Q
END1 K DA,GMRCDT,GMRCPCNT,GMRCIDT,GMRCTRLC,GMRCOM
K ^TMP("GMRCS",$J),^TMP("GMRCSLIST",$J)
Q
;
TIURSL ;Get TIU results to update the Consults package
;One time run to get the information TIU has into the consults package.
;
F PASS=1,2 D LOOP
Q
;
LOOP ;LOOP Thru TIU entries to populate the 50th node.
S TIUDA=0,TIUEDT=2980500,GMRCY=0
F S TIUEDT=$O(^TIU(8925,"F",TIUEDT)) Q:'TIUEDT D
. S TIUDA=$O(^TIU(8925,"F",TIUEDT,"")) Q:'TIUDA
. Q:'$D(^TIU(8925,TIUDA,14))
. S GMRCO=$P($G(^TIU(8925,TIUDA,14)),"^",5)
. Q:$P(GMRCO,";",2)'="GMR(123,"
. Q:'$D(^GMR(123,+GMRCO,0))
. I PASS=1 K ^GMR(123,+GMRCO,50) Q
. ;PASS 2 ADD
. S GMRCVDA=TIUDA_";TIU(8925,"
. D ADDRSLT^GMRCTIUA(+GMRCO,GMRCVDA)
Q
;
ONETIME ;One time run to load the file 123 consult entry multiple results
;with the TIU Narrative Result
;
N ZTSK
S ZTSK=$$QUEUE("ONETIMER^GMRCSTSU","One time run to load the file 123 consult entry multiple results and rebuild cross-references")
I ZTSK W !,"One time load Queued to run. Task#",ZTSK
E W !,"One Time load failed to queue."
Q
;
ONETIMER ;
D XREF
D NWXREF
S GMRCDT=2970100,GMRCY=0
F S GMRCDT=$O(^GMR(123,"B",GMRCDT)) Q:'GMRCDT D
. S GMRCO=0 F S GMRCO=$O(^GMR(123,"B",GMRCDT,GMRCO)) Q:'GMRCO D
.. I '$D(^GMR(123,+GMRCO,50)),+$P($G(^GMR(123,+GMRCO,0)),"^",20) S GMRCY=$$LOAD^GMRCTIUA(GMRCO)
;
Q
XREF ;re-create cross references for specific fields in files
N SVC
D BMES^XPDUTL("Re-indexing APC cross reference for service entries ")
K ^GMR(123.5,"APC")
S SVC=0
F S SVC=$O(^GMR(123.5,SVC)) Q:'SVC D
. S DA(1)=SVC
. S DIK="^GMR(123.5,"_DA(1)_",10,"
. S DIK(1)=".01^APC"
. D ENALL^DIK
D BMES^XPDUTL("Re-indexing AC cross reference for sub-service entries ")
S SVC=0
F S SVC=$O(^GMR(123.5,SVC)) Q:'SVC D
. K ^GMR(123.5,SVC,10,"AC")
. S DA(1)=SVC
. S DIK="^GMR(123.5,"_DA(1)_",10,"
. S DIK(1)=".01^AC"
. D ENALL^DIK
Q
;
;
NWXREF ;Create new cross references for specific fields in file 123
N DIK
D BMES^XPDUTL("Creating new G cross-reference on Sending Provider for consults in 123 ...")
S DIK="^GMR(123,"
S DIK(1)="10^G"
D ENALL^DIK
;
D BMES^XPDUTL("Creating new H cross-reference on FROM location for consults in 123 ...")
S DIK="^GMR(123,"
S DIK(1)="2^H"
D ENALL^DIK
;
D BMES^XPDUTL("Creating new R cross-reference on consult results in file 123 ...")
N GMRCO,DIK,DA
S GMRCO=0
F S GMRCO=$O(^GMR(123,GMRCO)) Q:'GMRCO D
. S DA(1)=GMRCO
. S DIK="^GMR(123,"_DA(1)_",50,"
. S DIK(1)=".01^R"
. D ENALL^DIK
Q
;
QUEUE(ZTRTN,ZTDESC,ZTDTH,ZTIO) ;
;
; ZTRTN -- ROUTINE TO RUN (MANDATORY)
; ZTDESC - DESCRIPTION OF THE TASK (OPTIONAL)
; ZTDTH -- TIME TO RUN (OPTIONAL - DEFAULT = NOW)
; ZTIO --- DEVICE TO SEND OUTPUT TO (OPTIONAL)
;
N ZTCPU,ZTPAR,ZTPRE,ZTPRI
N ZTSAVE,ZTSK,ZTUCI
;
Q:'$L($G(ZTRTN)) 0
S:'$L($G(ZTDESC)) ZTDESC="CONSULT/REQUEST PACKAGE TASK"
S:'$L($G(ZTIO)) ZTIO=""
S:'$L($G(ZTDTH)) ZTDTH=$H
D ^%ZTLOAD
;
Q $G(ZTSK)
;
GMRCSTSU ;SLC/DLT - Change status based on current order status ;7/16/98 03:43
+1 ;;3.0;CONSULT/REQUEST TRACKING;**4**;DEC 27, 1997
CPRSUPD(GMRCO) ;Update CPRS order with new status
+1 ;GMRCO=IEN from file 123
+2 QUIT
+3 NEW DFN,CTRLCODE,GMRCSTS,GMRCPROV,GMRCORFN,ORSTS,ORIFN
+4 SET GMRCSTS=$PIECE(^GMR(123,+GMRCO,0),"^",12)
SET GMRCORFN=$PIECE(^(0),"^",3)
SET DFN=$PIECE(^(0),"^",2)
SET GMRCPROV=$PIECE(^(0),"^",14)
+5 ;S CTRLCODE=$S(GMRCSTS=5:"ZU",GMRCSTS=6:"ZU",1:"ZR")
+6 ;S DIE="^GMR(123,",DA=GMRCO,DR=".03////^S X=""@"""
+7 ;D ^DIE
+8 KILL GMRCSTS,DIE,DA,DR
+9 QUIT
+10 ;D EN^GMRCHL7(DFN,+GMRCO,"","",CTRLCODE,GMRCPROV,"","") ;Send CPRS an HL-7 message about status of purge - can/can't purge record
+11 QUIT
END QUIT
END1 KILL DA,GMRCDT,GMRCPCNT,GMRCIDT,GMRCTRLC,GMRCOM
+1 KILL ^TMP("GMRCS",$JOB),^TMP("GMRCSLIST",$JOB)
+2 QUIT
+3 ;
TIURSL ;Get TIU results to update the Consults package
+1 ;One time run to get the information TIU has into the consults package.
+2 ;
+3 FOR PASS=1,2
DO LOOP
+4 QUIT
+5 ;
LOOP ;LOOP Thru TIU entries to populate the 50th node.
+1 SET TIUDA=0
SET TIUEDT=2980500
SET GMRCY=0
+2 FOR
SET TIUEDT=$ORDER(^TIU(8925,"F",TIUEDT))
IF 'TIUEDT
QUIT
Begin DoDot:1
+3 SET TIUDA=$ORDER(^TIU(8925,"F",TIUEDT,""))
IF 'TIUDA
QUIT
+4 IF '$DATA(^TIU(8925,TIUDA,14))
QUIT
+5 SET GMRCO=$PIECE($GET(^TIU(8925,TIUDA,14)),"^",5)
+6 IF $PIECE(GMRCO,";",2)'="GMR(123,"
QUIT
+7 IF '$DATA(^GMR(123,+GMRCO,0))
QUIT
+8 IF PASS=1
KILL ^GMR(123,+GMRCO,50)
QUIT
+9 ;PASS 2 ADD
+10 SET GMRCVDA=TIUDA_";TIU(8925,"
+11 DO ADDRSLT^GMRCTIUA(+GMRCO,GMRCVDA)
End DoDot:1
+12 QUIT
+13 ;
ONETIME ;One time run to load the file 123 consult entry multiple results
+1 ;with the TIU Narrative Result
+2 ;
+3 NEW ZTSK
+4 SET ZTSK=$$QUEUE("ONETIMER^GMRCSTSU","One time run to load the file 123 consult entry multiple results and rebuild cross-references")
+5 IF ZTSK
WRITE !,"One time load Queued to run. Task#",ZTSK
+6 IF '$TEST
WRITE !,"One Time load failed to queue."
+7 QUIT
+8 ;
ONETIMER ;
+1 DO XREF
+2 DO NWXREF
+3 SET GMRCDT=2970100
SET GMRCY=0
+4 FOR
SET GMRCDT=$ORDER(^GMR(123,"B",GMRCDT))
IF 'GMRCDT
QUIT
Begin DoDot:1
+5 SET GMRCO=0
FOR
SET GMRCO=$ORDER(^GMR(123,"B",GMRCDT,GMRCO))
IF 'GMRCO
QUIT
Begin DoDot:2
+6 IF '$DATA(^GMR(123,+GMRCO,50))
IF +$PIECE($GET(^GMR(123,+GMRCO,0)),"^",20)
SET GMRCY=$$LOAD^GMRCTIUA(GMRCO)
End DoDot:2
End DoDot:1
+7 ;
+8 QUIT
XREF ;re-create cross references for specific fields in files
+1 NEW SVC
+2 DO BMES^XPDUTL("Re-indexing APC cross reference for service entries ")
+3 KILL ^GMR(123.5,"APC")
+4 SET SVC=0
+5 FOR
SET SVC=$ORDER(^GMR(123.5,SVC))
IF 'SVC
QUIT
Begin DoDot:1
+6 SET DA(1)=SVC
+7 SET DIK="^GMR(123.5,"_DA(1)_",10,"
+8 SET DIK(1)=".01^APC"
+9 DO ENALL^DIK
End DoDot:1
+10 DO BMES^XPDUTL("Re-indexing AC cross reference for sub-service entries ")
+11 SET SVC=0
+12 FOR
SET SVC=$ORDER(^GMR(123.5,SVC))
IF 'SVC
QUIT
Begin DoDot:1
+13 KILL ^GMR(123.5,SVC,10,"AC")
+14 SET DA(1)=SVC
+15 SET DIK="^GMR(123.5,"_DA(1)_",10,"
+16 SET DIK(1)=".01^AC"
+17 DO ENALL^DIK
End DoDot:1
+18 QUIT
+19 ;
+20 ;
NWXREF ;Create new cross references for specific fields in file 123
+1 NEW DIK
+2 DO BMES^XPDUTL("Creating new G cross-reference on Sending Provider for consults in 123 ...")
+3 SET DIK="^GMR(123,"
+4 SET DIK(1)="10^G"
+5 DO ENALL^DIK
+6 ;
+7 DO BMES^XPDUTL("Creating new H cross-reference on FROM location for consults in 123 ...")
+8 SET DIK="^GMR(123,"
+9 SET DIK(1)="2^H"
+10 DO ENALL^DIK
+11 ;
+12 DO BMES^XPDUTL("Creating new R cross-reference on consult results in file 123 ...")
+13 NEW GMRCO,DIK,DA
+14 SET GMRCO=0
+15 FOR
SET GMRCO=$ORDER(^GMR(123,GMRCO))
IF 'GMRCO
QUIT
Begin DoDot:1
+16 SET DA(1)=GMRCO
+17 SET DIK="^GMR(123,"_DA(1)_",50,"
+18 SET DIK(1)=".01^R"
+19 DO ENALL^DIK
End DoDot:1
+20 QUIT
+21 ;
QUEUE(ZTRTN,ZTDESC,ZTDTH,ZTIO) ;
+1 ;
+2 ; ZTRTN -- ROUTINE TO RUN (MANDATORY)
+3 ; ZTDESC - DESCRIPTION OF THE TASK (OPTIONAL)
+4 ; ZTDTH -- TIME TO RUN (OPTIONAL - DEFAULT = NOW)
+5 ; ZTIO --- DEVICE TO SEND OUTPUT TO (OPTIONAL)
+6 ;
+7 NEW ZTCPU,ZTPAR,ZTPRE,ZTPRI
+8 NEW ZTSAVE,ZTSK,ZTUCI
+9 ;
+10 IF '$LENGTH($GET(ZTRTN))
QUIT 0
+11 IF '$LENGTH($GET(ZTDESC))
SET ZTDESC="CONSULT/REQUEST PACKAGE TASK"
+12 IF '$LENGTH($GET(ZTIO))
SET ZTIO=""
+13 IF '$LENGTH($GET(ZTDTH))
SET ZTDTH=$HOROLOG
+14 DO ^%ZTLOAD
+15 ;
+16 QUIT $GET(ZTSK)
+17 ;
