MCARPCS4.m

MCARPCS4 ;WISC/TJK-AUTO TRANSMIT PACEMAKER REPORT LOAD 4 ;8/5/96  09:04

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

 G BEGIN

STORE S MCLN=$E($P(MCLN1,U)_"                                        ",1,40)_MCLN2

STORE1 S ^TMP("MCAR","PACE",$J,MCLNCT)=MCLN,MCLNCT=MCLNCT+1 Q

BEGIN S MCLN=MCBL D STORE1 S MCLN="PACING FAILURE (EKG):" D STORE1 S MCLN=$E(MCDSH,1,21) D STORE1

 K DIC S DIC="^MCAR(698,",DR(698.093)=".01;1"

 F K=0:0 S K=$O(^MCAR(698,MCG,2,K)) Q:K'?1N.N  S DA=MCG,DR=93,DA(698.093)=K D EN^DIQ1 S MCLN1=M(698.093,K,.01,"E"),MCLN2="DATE OF FAILURE: "_M(698.093,K,1,"E") D STORE

 K M,DA,DR S MCLN=MCBL D STORE1 S M=$P(MCG(1),U,2) I M,$D(^MCAR(695.8,M,0)) S MCLN="INDICATION FOR GENERATOR CHANGE: "_$P(^(0),U) D STORE1

 K M S DA=MCG,DR=19 D EN^DIQ1 S MCLN="IMPLANTATION ETIOLOGY: "_$S('$D(M):"",1:M(698,MCG,19,"E")) D STORE1

 G VLREASON:'MCAL,VLREASON:'$D(^MCAR(698.2,MCAL,1)),VLREASON:'$P(^(1),U,2)

 K M,DR,DA,DIC S DIC="^MCAR(698.2,",DA=MCAL,DR=57 D EN^DIQ1 S MCLN="INDICATION FOR ELECTRODE CHANGE (A-LEAD): "_$S('$D(M):"",1:M(698.2,MCAL,57,"E")) D STORE1

VLREASON G REPRO:'MCVL,REPRO:'$D(^MCAR(698.1,MCVL,1)),REPRO:'$P(^(1),U,2)

 K M,DR,DA,DIC S DIC="^MCAR(698.1,",DA=MCVL,DR=57 D EN^DIQ1 S MCLN="INDICATION FOR ELECTRODE CHANGE (V-LEAD): "_$S('$D(M):"",1:M(698.1,MCVL,57,"E")) D STORE1

REPRO K M,DR,DA,DIC G XMIT:'MCS,XMIT:'$P(MCS(0),U,20) S M=$P(MCS(0),U,20) I $D(^MCAR(695.8,M,0)) S M=$P(^(0),U),MCLN="REASON FOR REPROGRAMMING: "_M D STORE1

XMIT S MCLN=MCDSH D STORE1

 K DIQ,DOB,I,J,K,M,M1,M2,MA,MCAL,MCARNM,MCBL,MCDIC,MCDSH

 K MCG,MCLAST,MCLN,MCLNCT,MCPHYS,MCR,MCTEL,MCTR,MCV,MCVL,MV

 K MCLN1,MCLN2,MCS,SEX,SSN,X,Y,Z

 S XMSUB="PACEMAKER CENTER REPORT",XMTEXT="^TMP(""MCAR"",""PACE"",$J,",XMDUZ=DUZ ;,XMY(DUZ)=""

 ;    set up recipients - TEMPORARILY Eastern Pacemaker Center only

 S X="G.WASH PACEMAKER@DOMAIN.NAME" D WHO^XMA21

 ; I MCT'["E" S X="G.SF PACEMAKER@SANFRANCISCO.VA.GOV" D WHO^XMA21

 D ^XMD ;    transmit the message

 D NOW^%DTC F I=1:1 Q:'$D(^MCAR(690,DFN,"P4",I))

 S ^MCAR(690,DFN,"P4",0)="^690.015^"_I_U_I,^(I,0)=%,^MCAR(690,DFN,"P4","B",%,I)=""

 K DFN,%T,%Y1,C,I,Y,%,%I,%H,^TMP("MCAR","PACE",$J),^UTILITY("DIQ1",$J) S:$D(ZTQUEUED) ZTREQ="@" K ZTSK Q

MCARPCS4  ;WISC/TJK-AUTO TRANSMIT PACEMAKER REPORT LOAD 4 ;8/5/96  09:04

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

 +2        GOTO BEGIN

STORE      SET MCLN=$EXTRACT($PIECE(MCLN1,U)_"                                        ",1,40)_MCLN2

STORE1     SET ^TMP("MCAR","PACE",$JOB,MCLNCT)=MCLN

           SET MCLNCT=MCLNCT+1

           QUIT 

BEGIN      SET MCLN=MCBL

           DO STORE1

           SET MCLN="PACING FAILURE (EKG):"

           DO STORE1

           SET MCLN=$EXTRACT(MCDSH,1,21)

           DO STORE1

 +1        KILL DIC

           SET DIC="^MCAR(698,"

           SET DR(698.093)=".01;1"

 +2        FOR K=0:0

               SET K=$ORDER(^MCAR(698,MCG,2,K))

               IF K'?1N.N

                   QUIT 

               SET DA=MCG

               SET DR=93

               SET DA(698.093)=K

               DO EN^DIQ1

               SET MCLN1=M(698.093,K,.01,"E")

               SET MCLN2="DATE OF FAILURE: "_M(698.093,K,1,"E")

               DO STORE

 +3        KILL M,DA,DR

           SET MCLN=MCBL

           DO STORE1

           SET M=$PIECE(MCG(1),U,2)

           IF M

               IF $DATA(^MCAR(695.8,M,0))

                   SET MCLN="INDICATION FOR GENERATOR CHANGE: "_$PIECE(^(0),U)

                   DO STORE1

 +4        KILL M

           SET DA=MCG

           SET DR=19

           DO EN^DIQ1

           SET MCLN="IMPLANTATION ETIOLOGY: "_$SELECT('$DATA(M):"",1:M(698,MCG,19,"E"))

           DO STORE1

 +5        IF 'MCAL

               GOTO VLREASON

           IF '$DATA(^MCAR(698.2,MCAL,1))

               GOTO VLREASON

           IF '$PIECE(^(1),U,2)

               GOTO VLREASON

 +6        KILL M,DR,DA,DIC

           SET DIC="^MCAR(698.2,"

           SET DA=MCAL

           SET DR=57

           DO EN^DIQ1

           SET MCLN="INDICATION FOR ELECTRODE CHANGE (A-LEAD): "_$SELECT('$DATA(M):"",1:M(698.2,MCAL,57,"E"))

           DO STORE1

VLREASON   IF 'MCVL

               GOTO REPRO

           IF '$DATA(^MCAR(698.1,MCVL,1))

               GOTO REPRO

           IF '$PIECE(^(1),U,2)

               GOTO REPRO

 +1        KILL M,DR,DA,DIC

           SET DIC="^MCAR(698.1,"

           SET DA=MCVL

           SET DR=57

           DO EN^DIQ1

           SET MCLN="INDICATION FOR ELECTRODE CHANGE (V-LEAD): "_$SELECT('$DATA(M):"",1:M(698.1,MCVL,57,"E"))

           DO STORE1

REPRO      KILL M,DR,DA,DIC

           IF 'MCS

               GOTO XMIT

           IF '$PIECE(MCS(0),U,20)

               GOTO XMIT

           SET M=$PIECE(MCS(0),U,20)

           IF $DATA(^MCAR(695.8,M,0))

               SET M=$PIECE(^(0),U)

               SET MCLN="REASON FOR REPROGRAMMING: "_M

               DO STORE1

XMIT       SET MCLN=MCDSH

           DO STORE1

 +1        KILL DIQ,DOB,I,J,K,M,M1,M2,MA,MCAL,MCARNM,MCBL,MCDIC,MCDSH

 +2        KILL MCG,MCLAST,MCLN,MCLNCT,MCPHYS,MCR,MCTEL,MCTR,MCV,MCVL,MV

 +3        KILL MCLN1,MCLN2,MCS,SEX,SSN,X,Y,Z

 +4       ;,XMY(DUZ)=""

           SET XMSUB="PACEMAKER CENTER REPORT"

           SET XMTEXT="^TMP(""MCAR"",""PACE"",$J,"

           SET XMDUZ=DUZ

 +5       ;    set up recipients - TEMPORARILY Eastern Pacemaker Center only

 +6        SET X="G.WASH PACEMAKER@DOMAIN.NAME"

           DO WHO^XMA21

 +7       ; I MCT'["E" S X="G.SF PACEMAKER@SANFRANCISCO.VA.GOV" D WHO^XMA21

 +8       ;    transmit the message

           DO ^XMD

 +9        DO NOW^%DTC

           FOR I=1:1

               IF '$DATA(^MCAR(690,DFN,"P4",I))

                   QUIT 

 +10       SET ^MCAR(690,DFN,"P4",0)="^690.015^"_I_U_I

           SET ^(I,0)=%

           SET ^MCAR(690,DFN,"P4","B",%,I)=""

 +11       KILL DFN,%T,%Y1,C,I,Y,%,%I,%H,^TMP("MCAR","PACE",$JOB),^UTILITY("DIQ1",$JOB)

           IF $DATA(ZTQUEUED)

               SET ZTREQ="@"

           KILL ZTSK

           QUIT