GMRCSTSU.m

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      ;