MCARPS.m

MCARPS ;WISC/TJK,RCH-PROCEDURE SUMMARY REPORTS ;6/18/97  10:53

 ;;2.3;Medicine;**8**;09/13/1996

CHOOZ K S5 R !,"PRINT BY DATE OR PROCEDURE (D/P): D//",WH:DTIME

 S WH=$E(WH,1) G BEG:"DP"[WH I WH'?1"^".E W:WH'?1"?".E *7,"  ??" D HELP G CHOOZ

 K WH,X,Y Q

BEG ;SEARCH FOR SELECTED PATIENT IN CARDIOLOGY FILE

 I WH="P" D PROC I $D(S5),S5=U G CHOOZ

 S DIC="^MCAR(690,",DIC(0)="AEQM"

 D ^DIC I Y<0 K WH,DIC,Y Q

 ; ------------------------

 ; SSN = Enternal Format of the patients SSN with the first letter

 ; of the last name tacked on the end

 ; ------------------------

 S DFN=+Y D DEM^VADPT S MCARNM=VADM(1),SSN=VA("PID")

 D INP^VADPT S WARD=$S(VAIN(4)'="":$P(VAIN(4),U,2),1:"NOT INPATIENT") D KVAR^VADPT

LOC ;LOCATE PROCEDURES FROM "AC" X-REF

 I '$D(^MCAR(690,"AC",DFN)) W !!,"NO PROCEDURES FOR THIS PATIENT" G BEG

 I $D(S5),'$D(@(U_S5_",""C"","_DFN_")")) W !!,"NO ",$P(@(U_S5_",0)"),U,1)," PROCEDURES FOR THIS PATIENT" G BEG

 D ^MCARPS1

PR K IO("Q") S %ZIS="QM" D ^%ZIS K %ZIS G EXIT:POP

 I $D(IO("Q")) K IO("Q") S ZTRTN="PR0^MCARPS",ZTDESC="PROCEDURE SUMMARY"

 I  S ZTSAVE("^TMP(""MCAR"",$J,")="",(ZTSAVE("DFN"),ZTSAVE("WH"),ZTSAVE("MC*"),ZTSAVE("SSN"),ZTSAVE("WARD"))="" D ^%ZTLOAD K ZTSK W !!,*7,"Report Queued" G FIN

 U IO

PR0 D TOP S I="",L=0

PR1 S I=$O(^TMP("MCAR",$J,I)) G PR1:I="OT" I I="" G EXP:IOST'?1"P-".E,FIN

 S J=""

PR2 S J=$O(^TMP("MCAR",$J,I,J)) G PR1:J=""

 S PR=^(J),MCARDT=$S(WH="P":$P(J,U),1:I),MCARPROC=$S(WH="P":I,1:$P(J,U))  ;MC*2.3*8

 S MCARPROC=$O(^MCAR(697.2,"B",MCARPROC,0)),MCARPROC=$P(^MCAR(697.2,MCARPROC,0),U,8)

 I $P(PR,U,12)'="" S MCARPROC=$P(PR,U,12)  ;MC*2.3*8

 S DA=$P(PR,U,2),K=$P(PR,U),M=$P(PR,U,10)

 S K=$S(K="N"!(K="L"):"NORMAL",K="A":"ABNORMAL",K="B":"BORDERLINE",K="T":"TECHNICALLY UNSATISFACTORY",K="ND":"NON-DIAGNOSTIC",K="MI":"MILDLY ABNORMAL",K="MO":"MODERATELY ABNORMAL",K="S":"SEVERELY ABNORMAL",1:"")

 ;S Y=9999999.9999-MCARDT X ^DD("DD") S L=L+1 W !,$J(L,2),?4,MCARPROC,?36,Y,?56,$E(K,1,22) W !,?1,M S ^TMP("MCAR",$J,"OT",L)=MCARPROC_U_DA_U_$P(PR,U,3,5)_U_J S $P(^(L),U,6)=Y,$P(^(L),U,7)=K,$P(^(L),U,10)=M,$P(^(L),U,11)=J

 S Y=9999999.9999-MCARDT X ^DD("DD") S L=L+1 W !,$J(L,2),?4,MCARPROC,?36,Y,?56,$E(K,1,22) W !,?1,M S ^TMP("MCAR",$J,"OT",L)=MCARPROC_U_DA_U_$P(PR,U,3,5)_U_J S $P(^(L),U,6)=Y,$P(^(L),U,7)=K,$P(^(L),U,10)=M,$P(^(L),U,11)=$S(WH="P":I_U_$P(J,U,2),1:J)

 S LN=LN+2 I LN'<(IOSL-2) G EXP:IOST'?1"P-".E D TOP

 G PR2

TOP W @IOF,!,"NAME: ",MCARNM,?35,"SSN: ",SSN,?55,"WARD: ",$E(WARD,1,19)

 ;W !!,"PROCEDURE",?36,"DATE",?56,"RESULTS",! F M=1:1:79 W "-"

 W !!,"(SUBSPECIALTY)/PROCEDURE",?36,"DATE",?56,"RESULTS" S M="",$P(M,"-",79)="-" W !,M

 S LN=6 Q

EXP G FIN:LN=6 W !!,*7,"FOR PROCEDURE EXPANSION (1-",L,") OR <RETURN> TO CONTINUE DISPLAY//" R R:DTIME G EXIT:R=U,EXIT:'$T

 I R'="",$D(^TMP("MCAR",$J,"OT",R)) G EXP1

 G FIN:I="" D TOP G PR2

EXP1 W @IOF,!! S OT=^TMP("MCAR",$J,"OT",R),(DA,MCARGDA)=$P(OT,U,2),MCARPPS=$P(OT,U,3,4),MCPRO=$P(OT,U,11) D MCPPROC^MCARP

 S MCARGRTN=$P(OT,U,5)

 K DXS D NEW,REDISP G EXP

FIN W:IOST'?1"P-".E !!,"END OF REPORT" W:IOST?1"P-".E @IOF D ^%ZISC

EXIT S:$D(ZTQUEUED) ZTREQ="@" K ZTSK

 K LN,PR,OT,DA,MCARPPS,I,J,R,L,S1,S2,S4,S5,S6,DFN,LL,LL1,MCARGRTN,POP,IO("Q")

 K ^TMP("MCAR",$J),K,N,MCARDT,WARD,MCARNM,MCARPROC,M,SSN

 ;The kill statement on next line will reset the TMP global for Imaging

 K ^TMP("MAG","ROW"),^("COL")

 Q

NEW N DFN,SSN,I,J,L D @MCARPPS Q

REDISP S MCL=$S(L#8:L-(L#8),1:L-8) D TOP

 F MCRED=MCL+1:1:MCL+8 Q:'$D(^TMP("MCAR",$J,"OT",MCRED))  S MCRED1=^(MCRED) W !,$J(MCRED,2),?4,$P(MCRED1,U),?36,$P(MCRED1,U,6),?56,$E($P(MCRED1,U,7),1,22),!,?1,$P(MCRED1,U,10) S LN=LN+2

 K MCL,MCRED,MCRED1 Q

PROC K PE,S5 R !,"Select Procedure:  ALL// ",S5:DTIME

 Q:S5=U  I S5="ALL"!(S5="") K S5 Q

 S DIC(0)="ZQE",DIC=697.2,X=S5 D ^DIC

 G PROC:Y<0 S S5=$P(Y(0),U,2),PE=$P(Y(0),U,1) Q

HELP W !,"You may sort this report by date or procedure.",!,"If you choose 'D' (date) all medical procedures will be displayed starting",!,"with the most recent procedure."

 W !,"If you choose 'P' (procedure), you may specify in the next prompt either a",!,"specific procedure or 'ALL' procedures, alphabetically arranged with the most",!,"recent of that type of procedure displayed first." Q

MCARPS    ;WISC/TJK,RCH-PROCEDURE SUMMARY REPORTS ;6/18/97  10:53

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

CHOOZ      KILL S5

           READ !,"PRINT BY DATE OR PROCEDURE (D/P): D//",WH:DTIME

 +1        SET WH=$EXTRACT(WH,1)

           IF "DP"[WH

               GOTO BEG

           IF WH'?1"^".E

               IF WH'?1"?".E

                   WRITE *7,"  ??"

               DO HELP

               GOTO CHOOZ

 +2        KILL WH,X,Y

           QUIT 

BEG       ;SEARCH FOR SELECTED PATIENT IN CARDIOLOGY FILE

 +1        IF WH="P"

               DO PROC

               IF $DATA(S5)

                   IF S5=U

                       GOTO CHOOZ

 +2        SET DIC="^MCAR(690,"

           SET DIC(0)="AEQM"

 +3        DO ^DIC

           IF Y<0

               KILL WH,DIC,Y

               QUIT 

 +4       ; ------------------------

 +5       ; SSN = Enternal Format of the patients SSN with the first letter

 +6       ; of the last name tacked on the end

 +7       ; ------------------------

 +8        SET DFN=+Y

           DO DEM^VADPT

           SET MCARNM=VADM(1)

           SET SSN=VA("PID")

 +9        DO INP^VADPT

           SET WARD=$SELECT(VAIN(4)'="":$PIECE(VAIN(4),U,2),1:"NOT INPATIENT")

           DO KVAR^VADPT

LOC       ;LOCATE PROCEDURES FROM "AC" X-REF

 +1        IF '$DATA(^MCAR(690,"AC",DFN))

               WRITE !!,"NO PROCEDURES FOR THIS PATIENT"

               GOTO BEG

 +2        IF $DATA(S5)

               IF '$DATA(@(U_S5_",""C"","_DFN_")"))

                   WRITE !!,"NO ",$PIECE(@(U_S5_",0)"),U,1)," PROCEDURES FOR THIS PATIENT"

                   GOTO BEG

 +3        DO ^MCARPS1

PR         KILL IO("Q")

           SET %ZIS="QM"

           DO ^%ZIS

           KILL %ZIS

           IF POP

               GOTO EXIT

 +1        IF $DATA(IO("Q"))

               KILL IO("Q")

               SET ZTRTN="PR0^MCARPS"

               SET ZTDESC="PROCEDURE SUMMARY"

 +2       IF $TEST

               SET ZTSAVE("^TMP(""MCAR"",$J,")=""

               SET (ZTSAVE("DFN"),ZTSAVE("WH"),ZTSAVE("MC*"),ZTSAVE("SSN"),ZTSAVE("WARD"))=""

               DO ^%ZTLOAD

               KILL ZTSK

               WRITE !!,*7,"Report Queued"

               GOTO FIN

 +3        USE IO

PR0        DO TOP

           SET I=""

           SET L=0

PR1        SET I=$ORDER(^TMP("MCAR",$JOB,I))

           IF I="OT"

               GOTO PR1

           IF I=""

               IF IOST'?1"P-".E

                   GOTO EXP

               GOTO FIN

 +1        SET J=""

PR2        SET J=$ORDER(^TMP("MCAR",$JOB,I,J))

           IF J=""

               GOTO PR1

 +1       ;MC*2.3*8

           SET PR=^(J)

           SET MCARDT=$SELECT(WH="P":$PIECE(J,U),1:I)

           SET MCARPROC=$SELECT(WH="P":I,1:$PIECE(J,U))

 +2        SET MCARPROC=$ORDER(^MCAR(697.2,"B",MCARPROC,0))

           SET MCARPROC=$PIECE(^MCAR(697.2,MCARPROC,0),U,8)

 +3       ;MC*2.3*8

           IF $PIECE(PR,U,12)'=""

               SET MCARPROC=$PIECE(PR,U,12)

 +4        SET DA=$PIECE(PR,U,2)

           SET K=$PIECE(PR,U)

           SET M=$PIECE(PR,U,10)

 +5        SET K=$SELECT(K="N"!(K="L"):"NORMAL",K="A":"ABNORMAL",K="B":"BORDERLINE",K="T":"TECHNICALLY UNSATISFACTORY",K="ND":"NON-DIAGNOSTIC",K="MI":"MILDLY ABNORMAL",K="MO":"MODERATELY ABNORMAL",K="S":"SEVERELY ABNORMAL",1:"")

 +6       ;S Y=9999999.9999-MCARDT X ^DD("DD") S L=L+1 W !,$J(L,2),?4,MCARPROC,?36,Y,?56,$E(K,1,22) W !,?1,M S ^TMP("MCAR",$J,"OT",L)=MCARPROC_U_DA_U_$P(PR,U,3,5)_U_J S $P(^(L),U,6)=Y,$P(^(L),U,7)=K,$P(^(L),U,10)=M,$P(^(L),U,11)=J

 +7        SET Y=9999999.9999-MCARDT

           XECUTE ^DD("DD")

           SET L=L+1

           WRITE !,$JUSTIFY(L,2),?4,MCARPROC,?36,Y,?56,$EXTRACT(K,1,22)

           WRITE !,?1,M

           SET ^TMP("MCAR",$JOB,"OT",L)=MCARPROC_U_DA_U_$PIECE(PR,U,3,5)_U_J

           SET $PIECE(^(L),U,6)=Y

           SET $PIECE(^(L),U,7)=K

           SET $PIECE(^(L),U,10)=M

           SET $PIECE(^(L),U,11)=$SELECT(WH="P":I_U_$PIECE(J,U,2),1:J)

 +8        SET LN=LN+2

           IF LN'<(IOSL-2)

               IF IOST'?1"P-".E

                   GOTO EXP

               DO TOP

 +9        GOTO PR2

TOP        WRITE @IOF,!,"NAME: ",MCARNM,?35,"SSN: ",SSN,?55,"WARD: ",$EXTRACT(WARD,1,19)

 +1       ;W !!,"PROCEDURE",?36,"DATE",?56,"RESULTS",! F M=1:1:79 W "-"

 +2        WRITE !!,"(SUBSPECIALTY)/PROCEDURE",?36,"DATE",?56,"RESULTS"

           SET M=""

           SET $PIECE(M,"-",79)="-"

           WRITE !,M

 +3        SET LN=6

           QUIT 

EXP        IF LN=6

               GOTO FIN

           WRITE !!,*7,"FOR PROCEDURE EXPANSION (1-",L,") OR <RETURN> TO CONTINUE DISPLAY//"

           READ R:DTIME

           IF R=U

               GOTO EXIT

           IF '$TEST

               GOTO EXIT

 +1        IF R'=""

               IF $DATA(^TMP("MCAR",$JOB,"OT",R))

                   GOTO EXP1

 +2        IF I=""

               GOTO FIN

           DO TOP

           GOTO PR2

EXP1       WRITE @IOF,!!

           SET OT=^TMP("MCAR",$JOB,"OT",R)

           SET (DA,MCARGDA)=$PIECE(OT,U,2)

           SET MCARPPS=$PIECE(OT,U,3,4)

           SET MCPRO=$PIECE(OT,U,11)

           DO MCPPROC^MCARP

 +1        SET MCARGRTN=$PIECE(OT,U,5)

 +2        KILL DXS

           DO NEW

           DO REDISP

           GOTO EXP

FIN        IF IOST'?1"P-".E

               WRITE !!,"END OF REPORT"

           IF IOST?1"P-".E

               WRITE @IOF

           DO ^%ZISC

EXIT       IF $DATA(ZTQUEUED)

               SET ZTREQ="@"

           KILL ZTSK

 +1        KILL LN,PR,OT,DA,MCARPPS,I,J,R,L,S1,S2,S4,S5,S6,DFN,LL,LL1,MCARGRTN,POP,IO("Q")

 +2        KILL ^TMP("MCAR",$JOB),K,N,MCARDT,WARD,MCARNM,MCARPROC,M,SSN

 +3       ;The kill statement on next line will reset the TMP global for Imaging

 +4        KILL ^TMP("MAG","ROW"),^("COL")

 +5        QUIT 

NEW        NEW DFN,SSN,I,J,L

           DO @MCARPPS

           QUIT 

REDISP     SET MCL=$SELECT(L#8:L-(L#8),1:L-8)

           DO TOP

 +1        FOR MCRED=MCL+1:1:MCL+8

               IF '$DATA(^TMP("MCAR",$JOB,"OT",MCRED))

                   QUIT 

               SET MCRED1=^(MCRED)

               WRITE !,$JUSTIFY(MCRED,2),?4,$PIECE(MCRED1,U),?36,$PIECE(MCRED1,U,6),?56,$EXTRACT($PIECE(MCRED1,U,7),1,22),!,?1,$PIECE(MCRED1,U,10)

               SET LN=LN+2

 +2        KILL MCL,MCRED,MCRED1

           QUIT 

PROC       KILL PE,S5

           READ !,"Select Procedure:  ALL// ",S5:DTIME

 +1        IF S5=U

               QUIT 

           IF S5="ALL"!(S5="")

               KILL S5

               QUIT 

 +2        SET DIC(0)="ZQE"

           SET DIC=697.2

           SET X=S5

           DO ^DIC

 +3        IF Y<0

               GOTO PROC

           SET S5=$PIECE(Y(0),U,2)

           SET PE=$PIECE(Y(0),U,1)

           QUIT 

HELP       WRITE !,"You may sort this report by date or procedure.",!,"If you choose 'D' (date) all medical procedures will be displayed starting",!,"with the most recent procedure."

 +1        WRITE !,"If you choose 'P' (procedure), you may specify in the next prompt either a",!,"specific procedure or 'ALL' procedures, alphabetically arranged with the most",!,"recent of that type of procedure displayed first."

           QUIT