source: FOIAVistA/trunk/r/SCHEDULING-SD-SC/SDAMBMR2.m@ 812

Last change on this file since 812 was 628, checked in by George Lilly, 15 years ago

initial load of FOIAVistA 6/30/08 version
File size: 5.1 KB
Line 
1SDAMBMR2 ;ALB/MLI - PRINT AMBULATORY PROCEDURES MANAGEMENT REPORTS ; 4/27/00 12:14pm
2 ;;5.3;Scheduling;**28,140,132,180,339,387,402**;Aug 13, 1993
3HD S SDPG=SDPG+1 W @IOF,!?20,"AMBULATORY PROCEDURE MANAGEMENT REPORTS",!!,"DATE RANGE: ",SDB,"-",SDE,?50,"DATE PRINTED: ",SDNOW,!,$S(SDFL:SDSTR_" NAME:",1:"ALL "_SDSTR_"S"),?16,SDT,?71,"PAGE: ",$J(SDPG,3) Q
4DT S SDB=SDB+.1,SDE=SDE-.9,SDB=$TR($$FMTE^XLFDT(SDB,"5DF")," ","0"),SDE=$TR($$FMTE^XLFDT(SDE,"5DF")," ","0") Q
51 S SDSTR=$S(SDSC="C":"CLINIC",1:"SERVICE") D DT G 2:SDRT="E" I SDSC="C" S I=0 F I1=0:0 S I=$S(VAUTC:$O(^TMP($J,I)),1:$O(VAUTC(I))) Q:I=""!SDFG I $D(^TMP($J,I,"T")),^("T") S SDT=I,SDFL=1 D P^SDAMBMR3 Q:SDFG
6 I SDSC="S" F I="M","N","P","R","S" I SDAS!$D(SDS(I)) I ^TMP($J,I,"T") D SET,P^SDAMBMR3 Q:SDFG
7 D TOT Q
82 G 3:SDPN="N" S I=0
9 F I1=0:0 D:I'=0 P^SDAMBMR3 Q:SDFG S I=$O(^TMP($J,"*PRO",I)) Q:I=""!(SDSC="S"&I)!SDFG D SET,HD2 Q:SDFG F J=0:0 D:J T S J=$O(^TMP($J,"*PRO",I,J)) Q:J="" D CD,PN:SDPT=1 D:$Y>(IOSL-5) HD2 Q:SDFG
10 D TOT Q
113 S (SDFL,I)=0,SDSTR=$S(SDSC="C":"CLINIC",1:"SERVICE")
12 F I1=0:0 D:SDFL P^SDAMBMR3 S SDFL=0,I=$O(^TMP($J,"*PTC",I)) Q:I=""!SDFG D SET,HD3 Q:SDFG D CONT
13 D TOT Q
14CONT S J=0 F J1=0:0 S J=$O(^TMP($J,"*PTC",I,J)) Q:J=""!SDFG S K=0 F K1=0:0 S K=$O(^TMP($J,"*PTC",I,J,K)) Q:K="" D C D:$Y>(IOSL-5) HD3 Q:SDFG
15 Q
16PN S L=0,K="A"
17 F K1=0:0 S K=$O(^TMP($J,"*PRO",I,J,K)) Q:K=""!SDFG F L1=0:0 S L=$O(^TMP($J,"*PRO",I,J,K,L)) Q:L=""!SDFG F M=0:0 S M=$O(^TMP($J,"*PRO",I,J,K,L,M)) Q:M="" S SDINFO=^(M) D PNAME D:$Y>(IOSL-5) HD2 Q:SDFG
18 Q
19 ;
20PNAME N %
21 F %=1:1:$P(SDINFO,U,4) W !,?8,$E(K,1,18),?28,$P(SDINFO,U,10),?39,"AGE: ",$J($P(SDINFO,U,2),3),?49,$S($P(SDINFO,U)=1:"VETERAN",1:"NON-VET"),?58,$P(SDINFO,U,3),?61 S VADAT("W")=M D ^VADATE W VADATE("E")
22 Q
23 ;
24 ;If prompt "Sort by 'P'rocedure or patient 'N'ame: P//PROCEDURE"
25 ;CPTMOD is called to print Procedure (CPT) codes and associated
26 ;Modifiers.
27CD N BLKLN,MODCODE,MODINFO,MODTEXT,MODVAL,SDJJ,KK,ICPTVDT
28 S (BLKLN,MODVAL)=0,SDHI=I D HD2:($Y>(IOSL-5)) Q:SDFG
29 S %DT="X",X=SDE D ^%DT S ICPTVDT=$S(Y<0:DT,1:Y)
30 S J=$P($$CPT^ICPTCOD(J,ICPTVDT),"^",1) ; equals IEN for CPT
31 S KK=$P($$CPT^ICPTCOD(J,ICPTVDT),"^",2) ; SD*5.3*339 external CPT value
32 W !!,$G(KK) ; SD*5.3*339 print external CPT code
33 S I=J D N W ?7,$E(SDN,1,72) S I=SDHI
34 Q:'SDMOD
35 I $D(^TMP($J,"*PRO",I,J,0)) S MODVAL=$P(^TMP($J,"*PRO",I,J,0),"^",2,99)
36 I $D(^TMP($J,"*PRO",I,J,1)) S MODVAL=$P(^TMP($J,"*PRO",I,J,1),"^",2,99)
37 Q:'MODVAL
38 F SDJJ=1:1:$L(MODVAL,"^") S MODINFO=$P(MODVAL,"^",SDJJ) D
39 . S MODINFO=$$MOD^ICPTMOD(MODINFO,"I",ICPTVDT,1)
40 . Q:MODINFO'>0
41 . S MODCODE="-"_$P(MODINFO,"^",2)
42 . S MODTEXT=$P(MODINFO,"^",3)
43 . W !?2,MODCODE,?8,$E(MODTEXT,1,65)
44 . Q
45 W !
46 Q
47HD2 Q:SDFG I IOST?1"C-".E R !?20,"Enter <RETURN> to continue",SDFG1:DTIME I SDFG1["^"!'$T S SDFG=1 Q
48 D HD W !!?25,"SUMMARY OF PROCEDURES PERFORMED",! K Y S $P(Y,"-",81)="" W Y Q
49HD3 Q:SDFG I IOST?1"C-".E R !?20,"Enter <RETURN> to continue",SDFG1:DTIME I SDFG1["^"!'$T S SDFG=1 Q
50 D HD W !!?31,"SUMMARY BY PATIENT",!,"NAME",?27,"SSN",?38,"AGE",?43,"VET/NON",?53,"SEX",?60,"DATE/TIME OF STOP",! K Y S $P(Y,"-",81)="" W Y
51SET S SDT=$S(SDSC="C":I,I="M":"MEDICINE",I="N":"NEUROLOGY",I="P":"PSYCHIATRY",I="R":"REHAB MEDICINE",I="S":"SURGERY",I="Z":"NONE",1:"UNKNOWN"),SDFL=1 Q
52T W !?8,"TOTAL PROCEDURES==>",?30,"VETERAN:",?39,$J($S($D(^TMP($J,"*PRO",I,J,1)):$P(^(1),"^",1),1:0),4),?47,"NON-VETERAN:",$J($S($D(^(0)):$P(^(0),"^",1),1:0),4)
53 W ?69,"TOTAL:",?76,$J($S($D(^TMP($J,"*PRO",I,J,0))&$D(^(1)):$P(^(0),"^",1)+$P(^(1),"^",1),'$D(^(0)):$P(^(1),"^",1),1:$P(^(0),"^",1)),4) Q
54C F L=-1:0 S L=$O(^TMP($J,"*PTC",I,J,K,L)) Q:L="" F M=0:0 S M=$O(^TMP($J,"*PTC",I,J,K,L,M)) Q:M="" M SDINFO=^(M) D C2
55 Q
56C2 W !!,$E(J,1,24),?27,$P(SDINFO,U,10) ; 10th piece is ssn
57 W ?38,$P(SDINFO,U),?43,$S(L=1:"VETERAN",1:"NON-VET"),?52,$S($P(SDINFO,U,2)="M":" MALE",1:"FEMALE"),?60 S VADAT("W")=M D ^VADATE W VADATE("E") D LIST
58 Q
59 ;
60 ;If "Sort by 'P'rocedure or patient 'N'ame: P//NAME" the patient name
61 ;,Procedure (CPT) Codes and Modifiers will be printed.
62LIST N BLKLN,MODCODE,MODINFO,MODTEXT,MODVAL,SDJJ,ICPTVDT
63 S %DT="X",X=SDE D ^%DT S ICPTVDT=$S(Y<0:DT,1:Y)
64 S BLKLN=1
65 F PR=11:1 S SDPRO=$P(SDINFO,U,PR) Q:'SDPRO D
66 . S SDHI=I D HD:($Y>(IOSL)) Q:SDFG
67 . W !?5,$P($$CPT^ICPTCOD(SDPRO,ICPTVDT),U,2) S I=SDPRO D N ; SD*5.3*402
68 . W ?12,$E(SDN,1,67) S I=SDHI
69 . Q:'SDMOD
70 . S MODVAL=SDINFO(PR-10)
71 . F SDJJ=1:1:$L(MODVAL,"^") S MODINFO=$P(MODVAL,"^",SDJJ) D
72 . . S MODINFO=$$MOD^ICPTMOD(MODINFO,"I",ICPTVDT,1)
73 . . Q:MODINFO'>0
74 . . S MODCODE="-"_$P(MODINFO,"^",2)
75 . . S MODTEXT=$P(MODINFO,"^",3)
76 . . W !?7,MODCODE,?13,$E(MODTEXT,1,65)
77 . . Q
78 . W !
79 . Q
80 Q
81TOT Q:SDFG K I S SDT="",SDFL=0 D P^SDAMBMR3 Q
82 ;
83 ;Retrieves the Procedure (CPT) Code description by calling API
84 ;CPTD^ICPTCOD
85N N DATA,SDIX,SDDATA,SDCOUNT,ICPTVDT
86 S %DT="X",X=SDE D ^%DT S ICPTVDT=$S(Y<0:DT,1:Y)
87 S SDN="",DATA=""
88 ;F S DATA=$O(DESCR(DATA)) Q:'DATA S SDN=SDN_" "_DESCR(DATA) Q:$L(SDN)>72
89 ;SDDATA will contain the returned information from the call to CPTD^ICPTCOD.
90 ;This is an extrinsic function, and can't be called with a "Do" statement.
91 S SDDATA=$$CPTD^ICPTCOD(I,"DESCR",,ICPTVDT)
92 S SDCOUNT=$P(SDDATA,"^",1)
93 F SDIX=1:1:SDCOUNT S SDN=SDN_" "_DESCR(SDIX) Q:$L(SDN)>72
94 S SDN=$E(SDN,1,72)
95 Q
Note: See TracBrowser for help on using the repository browser.