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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HMCARPS 4228 printed Apr 09, 2024@21:14:46 Page 2
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
