Routine: MCARPCS

MCARPCS ;WISC/TJK-AUTO TRANSMIT PACEMAKER REPORT-QUEUE ;4/10/96  14:14

 ;;2.3;Medicine;;09/13/1996

 W @IOF,!!!,"FORM TRANSFER TO NATIONAL CENTER"

 K DIC S DIC="^MCAR(690,",DIC(0)="AEQ",DIC("S")="I $D(^MCAR(698,""C"",+Y))" D ^DIC G EXIT:Y<0

 S DFN=+Y K MCR

REASON K DIC S DIC="^MCAR(695.8,",DIC(0)="AEQ",DIC("S")="I $D(^MCAR(695.8,""AC"",""T"",+Y))",DIC("A")="Select Reason for Transmission of this Report: " D ^DIC G EXIT:X=U,OK:Y<0 S MCR($P(^MCAR(695.8,+Y,0),U))="" G REASON

OK ;temporarily all transmissions will go to the Eastern Pacemaker Center

 S MCT="E"

 ;S MCT="" I $D(^MCAR(690,DFN,"P2")) S MCT=$P(^("P2"),U,2) S:MCT'="W" MCT="E"

 ;S:MCT="" MCT="E" W !!,"Transfer Report to : "_$S(MCT="W":"WESTERN PACEMAKER CENTER",1:"EASTERN PACEMAKER CENTER")_"//" R X:DTIME G EXIT:'$T,EXIT:X=U S X=$E(X,1)

 ;I "WEB"'[X W !,*7,"Answer with 'E' for Eastern Center,'W' for Western Center, or 'B' for Both" G OK

 ;S:X'="" MCT=X W !,$S(MCT="E":"EASTERN PACEMAKER CENTER",MCT="W":"WESTERN PACEMAKER CENTER",1:"BOTH EASTERN AND WESTERN PACEMAKER CENTERS")

 K DIC,DIR

 S DIR("A")="TRANSMIT REPORT",DIR("B")="Y",DIR(0)="Y"

 D ^DIR

 I Y S ZTRTN="^MCARPCS1",ZTSAVE("DFN")="",ZTSAVE("MCR(")="",ZTSAVE("DUZ")="",ZTSAVE("MCT")="",ZTIO="",ZTDESC="PACEMAKER REPORT TRANSMISSION" D ^%ZTLOAD

EXIT K MCR,X,Y,%,ZTSK,DFN,MCT,DIR Q

MCARPCS   ;WISC/TJK-AUTO TRANSMIT PACEMAKER REPORT-QUEUE ;4/10/96  14:14

 +1       ;;2.3;Medicine;;09/13/1996

 +2        WRITE @IOF,!!!,"FORM TRANSFER TO NATIONAL CENTER"

 +3        KILL DIC

           SET DIC="^MCAR(690,"

           SET DIC(0)="AEQ"

           SET DIC("S")="I $D(^MCAR(698,""C"",+Y))"

           DO ^DIC

           IF Y<0

               GOTO EXIT

 +4        SET DFN=+Y

           KILL MCR

REASON     KILL DIC

           SET DIC="^MCAR(695.8,"

           SET DIC(0)="AEQ"

           SET DIC("S")="I $D(^MCAR(695.8,""AC"",""T"",+Y))"

           SET DIC("A")="Select Reason for Transmission of this Report: "

           DO ^DIC

           IF X=U

               GOTO EXIT

           IF Y<0

               GOTO OK

           SET MCR($PIECE(^MCAR(695.8,+Y,0),U))=""

           GOTO REASON

OK        ;temporarily all transmissions will go to the Eastern Pacemaker Center

 +1        SET MCT="E"

 +2       ;S MCT="" I $D(^MCAR(690,DFN,"P2")) S MCT=$P(^("P2"),U,2) S:MCT'="W" MCT="E"

 +3       ;S:MCT="" MCT="E" W !!,"Transfer Report to : "_$S(MCT="W":"WESTERN PACEMAKER CENTER",1:"EASTERN PACEMAKER CENTER")_"//" R X:DTIME G EXIT:'$T,EXIT:X=U S X=$E(X,1)

 +4       ;I "WEB"'[X W !,*7,"Answer with 'E' for Eastern Center,'W' for Western Center, or 'B' for Both" G OK

 +5       ;S:X'="" MCT=X W !,$S(MCT="E":"EASTERN PACEMAKER CENTER",MCT="W":"WESTERN PACEMAKER CENTER",1:"BOTH EASTERN AND WESTERN PACEMAKER CENTERS")

 +6        KILL DIC,DIR

 +7        SET DIR("A")="TRANSMIT REPORT"

           SET DIR("B")="Y"

           SET DIR(0)="Y"

 +8        DO ^DIR

 +9        IF Y

               SET ZTRTN="^MCARPCS1"

               SET ZTSAVE("DFN")=""

               SET ZTSAVE("MCR(")=""

               SET ZTSAVE("DUZ")=""

               SET ZTSAVE("MCT")=""

               SET ZTIO=""

               SET ZTDESC="PACEMAKER REPORT TRANSMISSION"

               DO ^%ZTLOAD

EXIT       KILL MCR,X,Y,%,ZTSK,DFN,MCT,DIR

           QUIT

 +1        QUIT

MCARPCS.m