- MCARPAL ;WISC/TJK-PACEMAKER ACTIVE PATIENT LIST ;5/7/96 13:35
- ;;2.3;Medicine;**16**;09/13/1996
- W @IOF,!!,"ACTIVE PATIENT LIST"
- W !! F I=1:1:80 W "*"
- W !,"*",?37,"NOTICE",?79,"*"
- W !,"*",?79,"*",!,"*",?10,"This report has been set up to print with a line length of 132",?79,"*",!,"*",?10,"characters. Select a device that uses a 132 character line length.",?79,"*"
- W !,"*",?79,"*",! F I=1:1:80 W "*"
- W !!,"<RETURN> to continue " R X:DTIME G EXIT:'$T,EXIT:X=U
- K IO("Q") S %ZIS="QM" D ^%ZIS G EXIT:POP
- I $D(IO("Q")) K IO("Q") S ZTRTN="CALC^MCARPAL",ZTDESC="PACEMAKER ACTIVE PATIENT LIST" D ^%ZTLOAD K ZTSK G EXIT
- U IO
- CALC K ^TMP($J) S DFN=""
- CALC1 S DFN=$O(^MCAR(698,"C",DFN)) G PRINT:DFN=""
- S MCAREG="" S:$D(^MCAR(690,DFN,"P2")) MCAREG=$P(^("P2"),U) G CALC1:'MCAREG
- G CALC1:(MCAREG=2)!(MCAREG=3)!(MCAREG=5)!(MCAREG=6)!(MCAREG=8)
- D DEM^VADPT S MCARNM=VADM(1),DOB=$P(VADM(3),U,2),SSN=VADM(2)
- F DIC=698,698.1,698.2 S:DIC'=698.2 CT=0 S MCARCD=$S(DIC=698:"G",1:"L") D LEAD
- S ^TMP($J,MCARNM,0)=MCAREG_U_DOB_U_SSN G CALC1
- PRINT S PG=0,LN="-------------------------------------" D HEAD S MCARNM=""
- PRINT1 S MCARNM=$O(^TMP($J,MCARNM)) G EXIT:MCARNM="" S X=^(MCARNM,0)
- S A="" I $Y>(IOSL-3) R:IOST'?1"P-".E !,"<RETURN> to Continue",A:DTIME G EXIT:A=U D HEAD
- W !!,MCARNM S Y=$P(X,U,3) W !,$E(Y,1,3),"-",$E(Y,4,5),"-",$E(Y,6,9)
- W ?17 S Y=$P(X,U,2) W Y
- S Y=$P(X,U) W ?29,$S(Y=1:"EAST PSC FOLLOW-UP",Y=4:"REGISTRY ONLY",Y=7:"WEST PSC FOLLOW-UP",1:"")
- S A="" F I=1:1 Q:'$D(^TMP($J,MCARNM,"G",I))&('$D(^TMP($J,MCARNM,"L",I))) D PR I $Y>(IOSL-3) R:IOST'?1"P-".E !,"<RETURN> to Continue",A:DTIME Q:A=U D HEAD
- G EXIT:A=U,PRINT1
- EXIT ;
- I IOST'?1"P-".E R !!,"PRESS RETURN TO CONTINUE",X:DTIME
- K A,CT,DFN,DIC,DOB,I,LN,MCARCD,MCAREG,MCARNM,PG,POP,SSN,X,Y,Z,VA,VADM
- W:IOST?1"P-".E @IOF D ^%ZISC Q
- LEAD F I=0:0 S I=$O(^MCAR(DIC,"C",DFN,I)) Q:I="" S CT=CT+1,Y=^MCAR(DIC,I,0),^TMP($J,MCARNM,MCARCD,CT)=$P(Y,U,1)_U_$P(Y,U,3)_U_$P(Y,U,4)_U_$P(Y,U,5)_$S(MCARCD="G":"",1:U_DIC)
- Q
- PR W:I>1 !
- I $D(^TMP($J,MCARNM,"G",I)) S X=^(I),Y=$P(X,U,1) W ?51,$E(Y,4,5),"/",$E(Y,6,7),"/",$E(Y,2,3) D MANUF W ?60,Y,?64,Z,?77,$P(X,U,4)
- I $D(^TMP($J,MCARNM,"L",I)) S X=^(I),Y=$P(X,U,1) W ?90,$S($P(X,U,5)=698.1:"V: ",1:"A: "),$E(Y,4,5),"/",$E(Y,6,7),"/",$E(Y,2,3) D MANUF W ?102,Y,?106,Z,?119,$P(X,U,4)
- Q
- MANUF S Y=$P(X,U,3) I Y,$D(^MCAR(698.6,Y,0)) S Y=$P(^(0),U,2)
- S Z=$P(X,U,2) I Z,$D(^MCAR(698.4,Z,0)) S Z=$P(^(0),U)
- Q
- HEAD S PG=PG+1 W @IOF,!!,?47,"VETERANS ADMINISTRATION MEDICAL CENTER",?120,"Pg.",PG
- ;W !,?132-$L(^DD("SITE"))/2,^DD("SITE")
- W !,?132-$L($$GET1^DIQ(4.3,1,217))/2,$$GET1^DIQ(4.3,1,217)
- W !,?52,"PACEMAKER ACTIVE PATIENT LIST"
- W !!,"PATIENT",?51,"GENERATOR IMPLANT DATA",?93,"V AND A LEAD IMPLANT DATA"
- W !,"SSN",?17,"DOB",?29,"STATUS",?51,"DATE",?60,"MFR MODEL",?77,"SER. NO.",?93,"DATE",?102,"MFR MODEL",?119,"SER. NO."
- W !,?51,LN,?93,LN
- Q
- MCARPAL ;WISC/TJK-PACEMAKER ACTIVE PATIENT LIST ;5/7/96 13:35
- +1 ;;2.3;Medicine;**16**;09/13/1996
- +2 WRITE @IOF,!!,"ACTIVE PATIENT LIST"
- +3 WRITE !!
- FOR I=1:1:80
- WRITE "*"
- +4 WRITE !,"*",?37,"NOTICE",?79,"*"
- +5 WRITE !,"*",?79,"*",!,"*",?10,"This report has been set up to print with a line length of 132",?79,"*",!,"*",?10,"characters. Select a device that uses a 132 character line length.",?79,"*"
- +6 WRITE !,"*",?79,"*",!
- FOR I=1:1:80
- WRITE "*"
- +7 WRITE !!,"<RETURN> to continue "
- READ X:DTIME
- IF '$TEST
- GOTO EXIT
- IF X=U
- GOTO EXIT
- +8 KILL IO("Q")
- SET %ZIS="QM"
- DO ^%ZIS
- IF POP
- GOTO EXIT
- +9 IF $DATA(IO("Q"))
- KILL IO("Q")
- SET ZTRTN="CALC^MCARPAL"
- SET ZTDESC="PACEMAKER ACTIVE PATIENT LIST"
- DO ^%ZTLOAD
- KILL ZTSK
- GOTO EXIT
- +10 USE IO
- CALC KILL ^TMP($JOB)
- SET DFN=""
- CALC1 SET DFN=$ORDER(^MCAR(698,"C",DFN))
- IF DFN=""
- GOTO PRINT
- +1 SET MCAREG=""
- IF $DATA(^MCAR(690,DFN,"P2"))
- SET MCAREG=$PIECE(^("P2"),U)
- IF 'MCAREG
- GOTO CALC1
- +2 IF (MCAREG=2)!(MCAREG=3)!(MCAREG=5)!(MCAREG=6)!(MCAREG=8)
- GOTO CALC1
- +3 DO DEM^VADPT
- SET MCARNM=VADM(1)
- SET DOB=$PIECE(VADM(3),U,2)
- SET SSN=VADM(2)
- +4 FOR DIC=698,698.1,698.2
- IF DIC'=698.2
- SET CT=0
- SET MCARCD=$SELECT(DIC=698:"G",1:"L")
- DO LEAD
- +5 SET ^TMP($JOB,MCARNM,0)=MCAREG_U_DOB_U_SSN
- GOTO CALC1
- PRINT SET PG=0
- SET LN="-------------------------------------"
- DO HEAD
- SET MCARNM=""
- PRINT1 SET MCARNM=$ORDER(^TMP($JOB,MCARNM))
- IF MCARNM=""
- GOTO EXIT
- SET X=^(MCARNM,0)
- +1 SET A=""
- IF $Y>(IOSL-3)
- IF IOST'?1"P-".E
- READ !,"<RETURN> to Continue",A:DTIME
- IF A=U
- GOTO EXIT
- DO HEAD
- +2 WRITE !!,MCARNM
- SET Y=$PIECE(X,U,3)
- WRITE !,$EXTRACT(Y,1,3),"-",$EXTRACT(Y,4,5),"-",$EXTRACT(Y,6,9)
- +3 WRITE ?17
- SET Y=$PIECE(X,U,2)
- WRITE Y
- +4 SET Y=$PIECE(X,U)
- WRITE ?29,$SELECT(Y=1:"EAST PSC FOLLOW-UP",Y=4:"REGISTRY ONLY",Y=7:"WEST PSC FOLLOW-UP",1:"")
- +5 SET A=""
- FOR I=1:1
- IF '$DATA(^TMP($JOB,MCARNM,"G",I))&('$DATA(^TMP($JOB,MCARNM,"L",I)))
- QUIT
- DO PR
- IF $Y>(IOSL-3)
- IF IOST'?1"P-".E
- READ !,"<RETURN> to Continue",A:DTIME
- IF A=U
- QUIT
- DO HEAD
- +6 IF A=U
- GOTO EXIT
- GOTO PRINT1
- EXIT ;
- +1 IF IOST'?1"P-".E
- READ !!,"PRESS RETURN TO CONTINUE",X:DTIME
- +2 KILL A,CT,DFN,DIC,DOB,I,LN,MCARCD,MCAREG,MCARNM,PG,POP,SSN,X,Y,Z,VA,VADM
- +3 IF IOST?1"P-".E
- WRITE @IOF
- DO ^%ZISC
- QUIT
- LEAD FOR I=0:0
- SET I=$ORDER(^MCAR(DIC,"C",DFN,I))
- IF I=""
- QUIT
- SET CT=CT+1
- SET Y=^MCAR(DIC,I,0)
- SET ^TMP($JOB,MCARNM,MCARCD,CT)=$PIECE(Y,U,1)_U_$PIECE(Y,U,3)_U_$PIECE(Y,U,4)_U_$PIECE(Y,U,5)_$SELECT(MCARCD="G":"",1:U_DIC)
- +1 QUIT
- PR IF I>1
- WRITE !
- +1 IF $DATA(^TMP($JOB,MCARNM,"G",I))
- SET X=^(I)
- SET Y=$PIECE(X,U,1)
- WRITE ?51,$EXTRACT(Y,4,5),"/",$EXTRACT(Y,6,7),"/",$EXTRACT(Y,2,3)
- DO MANUF
- WRITE ?60,Y,?64,Z,?77,$PIECE(X,U,4)
- +2 IF $DATA(^TMP($JOB,MCARNM,"L",I))
- SET X=^(I)
- SET Y=$PIECE(X,U,1)
- WRITE ?90,$SELECT($PIECE(X,U,5)=698.1:"V: ",1:"A: "),$EXTRACT(Y,4,5),"/",$EXTRACT(Y,6,7),"/",$EXTRACT(Y,2,3)
- DO MANUF
- WRITE ?102,Y,?106,Z,?119,$PIECE(X,U,4)
- +3 QUIT
- MANUF SET Y=$PIECE(X,U,3)
- IF Y
- IF $DATA(^MCAR(698.6,Y,0))
- SET Y=$PIECE(^(0),U,2)
- +1 SET Z=$PIECE(X,U,2)
- IF Z
- IF $DATA(^MCAR(698.4,Z,0))
- SET Z=$PIECE(^(0),U)
- +2 QUIT
- HEAD SET PG=PG+1
- WRITE @IOF,!!,?47,"VETERANS ADMINISTRATION MEDICAL CENTER",?120,"Pg.",PG
- +1 ;W !,?132-$L(^DD("SITE"))/2,^DD("SITE")
- +2 WRITE !,?132-$LENGTH($$GET1^DIQ(4.3,1,217))/2,$$GET1^DIQ(4.3,1,217)
- +3 WRITE !,?52,"PACEMAKER ACTIVE PATIENT LIST"
- +4 WRITE !!,"PATIENT",?51,"GENERATOR IMPLANT DATA",?93,"V AND A LEAD IMPLANT DATA"
- +5 WRITE !,"SSN",?17,"DOB",?29,"STATUS",?51,"DATE",?60,"MFR MODEL",?77,"SER. NO.",?93,"DATE",?102,"MFR MODEL",?119,"SER. NO."
- +6 WRITE !,?51,LN,?93,LN
- +7 QUIT
