- 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@PACE-WASH.DOMAIN.EXT" D WHO^XMA21
- ; I MCT'["E" S X="G.SF PACEMAKER@SANFRANCISCO.DOMAIN.EXT" 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
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HMCARPCS4 2199 printed Mar 13, 2025@21:19:21 Page 2
- 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@PACE-WASH.DOMAIN.EXT"
- DO WHO^XMA21
- +7 ; I MCT'["E" S X="G.SF PACEMAKER@SANFRANCISCO.DOMAIN.EXT" 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
