Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: SDAMBMR2

SDAMBMR2.m

Go to the documentation of this file.
  1. SDAMBMR2 ;ALB/MLI - PRINT AMBULATORY PROCEDURES MANAGEMENT REPORTS ; 4/27/00 12:14pm
  1. ;;5.3;Scheduling;**28,140,132,180,339,387,402,1015**;Aug 13, 1993;Build 21
  1. HD 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
  1. DT S SDB=SDB+.1,SDE=SDE-.9,SDB=$TR($$FMTE^XLFDT(SDB,"5DF")," ","0"),SDE=$TR($$FMTE^XLFDT(SDE,"5DF")," ","0") Q
  1. 1 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
  1. 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
  1. D TOT Q
  1. 2 G 3:SDPN="N" S I=0
  1. 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
  1. D TOT Q
  1. 3 S (SDFL,I)=0,SDSTR=$S(SDSC="C":"CLINIC",1:"SERVICE")
  1. 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
  1. D TOT Q
  1. CONT 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
  1. Q
  1. PN S L=0,K="A"
  1. 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
  1. Q
  1. ;
  1. PNAME N %
  1. 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")
  1. Q
  1. ;
  1. ;If prompt "Sort by 'P'rocedure or patient 'N'ame: P//PROCEDURE"
  1. ;CPTMOD is called to print Procedure (CPT) codes and associated
  1. ;Modifiers.
  1. CD N BLKLN,MODCODE,MODINFO,MODTEXT,MODVAL,SDJJ,KK,ICPTVDT
  1. S (BLKLN,MODVAL)=0,SDHI=I D HD2:($Y>(IOSL-5)) Q:SDFG
  1. S %DT="X",X=SDE D ^%DT S ICPTVDT=$S(Y<0:DT,1:Y)
  1. S J=$P($$CPT^ICPTCOD(J,ICPTVDT),"^",1) ; equals IEN for CPT
  1. S KK=$P($$CPT^ICPTCOD(J,ICPTVDT),"^",2) ; SD*5.3*339 external CPT value
  1. W !!,$G(KK) ; SD*5.3*339 print external CPT code
  1. S I=J D N W ?7,$E(SDN,1,72) S I=SDHI
  1. Q:'SDMOD
  1. I $D(^TMP($J,"*PRO",I,J,0)) S MODVAL=$P(^TMP($J,"*PRO",I,J,0),"^",2,99)
  1. I $D(^TMP($J,"*PRO",I,J,1)) S MODVAL=$P(^TMP($J,"*PRO",I,J,1),"^",2,99)
  1. Q:'MODVAL
  1. F SDJJ=1:1:$L(MODVAL,"^") S MODINFO=$P(MODVAL,"^",SDJJ) D
  1. . S MODINFO=$$MOD^ICPTMOD(MODINFO,"I",ICPTVDT,1)
  1. . Q:MODINFO'>0
  1. . S MODCODE="-"_$P(MODINFO,"^",2)
  1. . S MODTEXT=$P(MODINFO,"^",3)
  1. . W !?2,MODCODE,?8,$E(MODTEXT,1,65)
  1. . Q
  1. W !
  1. Q
  1. HD2 Q:SDFG I IOST?1"C-".E R !?20,"Enter <RETURN> to continue",SDFG1:DTIME I SDFG1["^"!'$T S SDFG=1 Q
  1. D HD W !!?25,"SUMMARY OF PROCEDURES PERFORMED",! K Y S $P(Y,"-",81)="" W Y Q
  1. HD3 Q:SDFG I IOST?1"C-".E R !?20,"Enter <RETURN> to continue",SDFG1:DTIME I SDFG1["^"!'$T S SDFG=1 Q
  1. 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
  1. SET 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
  1. T 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)
  1. 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
  1. C 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
  1. Q
  1. C2 W !!,$E(J,1,24),?27,$P(SDINFO,U,10) ; 10th piece is ssn
  1. 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
  1. Q
  1. ;
  1. ;If "Sort by 'P'rocedure or patient 'N'ame: P//NAME" the patient name
  1. ;,Procedure (CPT) Codes and Modifiers will be printed.
  1. LIST N BLKLN,MODCODE,MODINFO,MODTEXT,MODVAL,SDJJ,ICPTVDT
  1. S %DT="X",X=SDE D ^%DT S ICPTVDT=$S(Y<0:DT,1:Y)
  1. S BLKLN=1
  1. F PR=11:1 S SDPRO=$P(SDINFO,U,PR) Q:'SDPRO D
  1. . S SDHI=I D HD:($Y>(IOSL)) Q:SDFG
  1. . W !?5,$P($$CPT^ICPTCOD(SDPRO,ICPTVDT),U,2) S I=SDPRO D N ; SD*5.3*402
  1. . W ?12,$E(SDN,1,67) S I=SDHI
  1. . Q:'SDMOD
  1. . S MODVAL=SDINFO(PR-10)
  1. . F SDJJ=1:1:$L(MODVAL,"^") S MODINFO=$P(MODVAL,"^",SDJJ) D
  1. . . S MODINFO=$$MOD^ICPTMOD(MODINFO,"I",ICPTVDT,1)
  1. . . Q:MODINFO'>0
  1. . . S MODCODE="-"_$P(MODINFO,"^",2)
  1. . . S MODTEXT=$P(MODINFO,"^",3)
  1. . . W !?7,MODCODE,?13,$E(MODTEXT,1,65)
  1. . . Q
  1. . W !
  1. . Q
  1. Q
  1. TOT Q:SDFG K I S SDT="",SDFL=0 D P^SDAMBMR3 Q
  1. ;
  1. ;Retrieves the Procedure (CPT) Code description by calling API
  1. ;CPTD^ICPTCOD
  1. N N DATA,SDIX,SDDATA,SDCOUNT,ICPTVDT
  1. S %DT="X",X=SDE D ^%DT S ICPTVDT=$S(Y<0:DT,1:Y)
  1. S SDN="",DATA=""
  1. ;F S DATA=$O(DESCR(DATA)) Q:'DATA S SDN=SDN_" "_DESCR(DATA) Q:$L(SDN)>72
  1. ;SDDATA will contain the returned information from the call to CPTD^ICPTCOD.
  1. ;This is an extrinsic function, and can't be called with a "Do" statement.
  1. S SDDATA=$$CPTD^ICPTCOD(I,"DESCR",,ICPTVDT)
  1. S SDCOUNT=$P(SDDATA,"^",1)
  1. F SDIX=1:1:SDCOUNT S SDN=SDN_" "_DESCR(SDIX) Q:$L(SDN)>72
  1. S SDN=$E(SDN,1,72)
  1. Q