SDAMBMR2 ;ALB/MLI - PRINT AMBULATORY PROCEDURES MANAGEMENT REPORTS ; 4/27/00 12:14pm
;;5.3;Scheduling;**28,140,132,180,339,387,402**;Aug 13, 1993
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
DT S SDB=SDB+.1,SDE=SDE-.9,SDB=$TR($$FMTE^XLFDT(SDB,"5DF")," ","0"),SDE=$TR($$FMTE^XLFDT(SDE,"5DF")," ","0") Q
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
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
D TOT Q
2 G 3:SDPN="N" S I=0
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
D TOT Q
3 S (SDFL,I)=0,SDSTR=$S(SDSC="C":"CLINIC",1:"SERVICE")
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
D TOT Q
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
Q
PN S L=0,K="A"
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
Q
;
PNAME N %
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")
Q
;
;If prompt "Sort by 'P'rocedure or patient 'N'ame: P//PROCEDURE"
;CPTMOD is called to print Procedure (CPT) codes and associated
;Modifiers.
CD N BLKLN,MODCODE,MODINFO,MODTEXT,MODVAL,SDJJ,KK,ICPTVDT
S (BLKLN,MODVAL)=0,SDHI=I D HD2:($Y>(IOSL-5)) Q:SDFG
S %DT="X",X=SDE D ^%DT S ICPTVDT=$S(Y<0:DT,1:Y)
S J=$P($$CPT^ICPTCOD(J,ICPTVDT),"^",1) ; equals IEN for CPT
S KK=$P($$CPT^ICPTCOD(J,ICPTVDT),"^",2) ; SD*5.3*339 external CPT value
W !!,$G(KK) ; SD*5.3*339 print external CPT code
S I=J D N W ?7,$E(SDN,1,72) S I=SDHI
Q:'SDMOD
I $D(^TMP($J,"*PRO",I,J,0)) S MODVAL=$P(^TMP($J,"*PRO",I,J,0),"^",2,99)
I $D(^TMP($J,"*PRO",I,J,1)) S MODVAL=$P(^TMP($J,"*PRO",I,J,1),"^",2,99)
Q:'MODVAL
F SDJJ=1:1:$L(MODVAL,"^") S MODINFO=$P(MODVAL,"^",SDJJ) D
. S MODINFO=$$MOD^ICPTMOD(MODINFO,"I",ICPTVDT,1)
. Q:MODINFO'>0
. S MODCODE="-"_$P(MODINFO,"^",2)
. S MODTEXT=$P(MODINFO,"^",3)
. W !?2,MODCODE,?8,$E(MODTEXT,1,65)
. Q
W !
Q
HD2 Q:SDFG I IOST?1"C-".E R !?20,"Enter <RETURN> to continue",SDFG1:DTIME I SDFG1["^"!'$T S SDFG=1 Q
D HD W !!?25,"SUMMARY OF PROCEDURES PERFORMED",! K Y S $P(Y,"-",81)="" W Y Q
HD3 Q:SDFG I IOST?1"C-".E R !?20,"Enter <RETURN> to continue",SDFG1:DTIME I SDFG1["^"!'$T S SDFG=1 Q
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
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
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)
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
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
Q
C2 W !!,$E(J,1,24),?27,$P(SDINFO,U,10) ; 10th piece is ssn
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
Q
;
;If "Sort by 'P'rocedure or patient 'N'ame: P//NAME" the patient name
;,Procedure (CPT) Codes and Modifiers will be printed.
LIST N BLKLN,MODCODE,MODINFO,MODTEXT,MODVAL,SDJJ,ICPTVDT
S %DT="X",X=SDE D ^%DT S ICPTVDT=$S(Y<0:DT,1:Y)
S BLKLN=1
F PR=11:1 S SDPRO=$P(SDINFO,U,PR) Q:'SDPRO D
. S SDHI=I D HD:($Y>(IOSL)) Q:SDFG
. W !?5,$P($$CPT^ICPTCOD(SDPRO,ICPTVDT),U,2) S I=SDPRO D N ; SD*5.3*402
. W ?12,$E(SDN,1,67) S I=SDHI
. Q:'SDMOD
. S MODVAL=SDINFO(PR-10)
. F SDJJ=1:1:$L(MODVAL,"^") S MODINFO=$P(MODVAL,"^",SDJJ) D
. . S MODINFO=$$MOD^ICPTMOD(MODINFO,"I",ICPTVDT,1)
. . Q:MODINFO'>0
. . S MODCODE="-"_$P(MODINFO,"^",2)
. . S MODTEXT=$P(MODINFO,"^",3)
. . W !?7,MODCODE,?13,$E(MODTEXT,1,65)
. . Q
. W !
. Q
Q
TOT Q:SDFG K I S SDT="",SDFL=0 D P^SDAMBMR3 Q
;
;Retrieves the Procedure (CPT) Code description by calling API
;CPTD^ICPTCOD
N N DATA,SDIX,SDDATA,SDCOUNT,ICPTVDT
S %DT="X",X=SDE D ^%DT S ICPTVDT=$S(Y<0:DT,1:Y)
S SDN="",DATA=""
;F S DATA=$O(DESCR(DATA)) Q:'DATA S SDN=SDN_" "_DESCR(DATA) Q:$L(SDN)>72
;SDDATA will contain the returned information from the call to CPTD^ICPTCOD.
;This is an extrinsic function, and can't be called with a "Do" statement.
S SDDATA=$$CPTD^ICPTCOD(I,"DESCR",,ICPTVDT)
S SDCOUNT=$P(SDDATA,"^",1)
F SDIX=1:1:SDCOUNT S SDN=SDN_" "_DESCR(SDIX) Q:$L(SDN)>72
S SDN=$E(SDN,1,72)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSDAMBMR2 5353 printed Sep 23, 2025@20:23:53 Page 2
SDAMBMR2 ;ALB/MLI - PRINT AMBULATORY PROCEDURES MANAGEMENT REPORTS ; 4/27/00 12:14pm
+1 ;;5.3;Scheduling;**28,140,132,180,339,387,402**;Aug 13, 1993
HD SET SDPG=SDPG+1
WRITE @IOF,!?20,"AMBULATORY PROCEDURE MANAGEMENT REPORTS",!!,"DATE RANGE: ",SDB,"-",SDE,?50,"DATE PRINTED: ",SDNOW,!,$SELECT(SDFL:SDSTR_" NAME:",1:"ALL "_SDSTR_"S"),?16,SDT,?71,"PAGE: ",$JUSTIFY(SDPG,3)
QUIT
DT SET SDB=SDB+.1
SET SDE=SDE-.9
SET SDB=$TRANSLATE($$FMTE^XLFDT(SDB,"5DF")," ","0")
SET SDE=$TRANSLATE($$FMTE^XLFDT(SDE,"5DF")," ","0")
QUIT
1 SET SDSTR=$SELECT(SDSC="C":"CLINIC",1:"SERVICE")
DO DT
if SDRT="E"
GOTO 2
IF SDSC="C"
SET I=0
FOR I1=0:0
SET I=$SELECT(VAUTC:$ORDER(^TMP($JOB,I)),1:$ORDER(VAUTC(I)))
if I=""!SDFG
QUIT
IF $DATA(^TMP($JOB,I,"T"))
IF ^("T")
SET SDT=I
SET SDFL=1
DO P^SDAMBMR3
if SDFG
QUIT
+1 IF SDSC="S"
FOR I="M","N","P","R","S"
IF SDAS!$DATA(SDS(I))
IF ^TMP($JOB,I,"T")
DO SET
DO P^SDAMBMR3
if SDFG
QUIT
+2 DO TOT
QUIT
2 if SDPN="N"
GOTO 3
SET I=0
+1 FOR I1=0:0
if I'=0
DO P^SDAMBMR3
if SDFG
QUIT
SET I=$ORDER(^TMP($JOB,"*PRO",I))
if I=""!(SDSC="S"&I)!SDFG
QUIT
DO SET
DO HD2
if SDFG
QUIT
FOR J=0:0
if J
DO T
SET J=$ORDER(^TMP($JOB,"*PRO",I,J))
if J=""
QUIT
DO CD
if SDPT=1
DO PN
if $Y>(IOSL-5)
DO HD2
if SDFG
QUIT
+2 DO TOT
QUIT
3 SET (SDFL,I)=0
SET SDSTR=$SELECT(SDSC="C":"CLINIC",1:"SERVICE")
+1 FOR I1=0:0
if SDFL
DO P^SDAMBMR3
SET SDFL=0
SET I=$ORDER(^TMP($JOB,"*PTC",I))
if I=""!SDFG
QUIT
DO SET
DO HD3
if SDFG
QUIT
DO CONT
+2 DO TOT
QUIT
CONT SET J=0
FOR J1=0:0
SET J=$ORDER(^TMP($JOB,"*PTC",I,J))
if J=""!SDFG
QUIT
SET K=0
FOR K1=0:0
SET K=$ORDER(^TMP($JOB,"*PTC",I,J,K))
if K=""
QUIT
DO C
if $Y>(IOSL-5)
DO HD3
if SDFG
QUIT
+1 QUIT
PN SET L=0
SET K="A"
+1 FOR K1=0:0
SET K=$ORDER(^TMP($JOB,"*PRO",I,J,K))
if K=""!SDFG
QUIT
FOR L1=0:0
SET L=$ORDER(^TMP($JOB,"*PRO",I,J,K,L))
if L=""!SDFG
QUIT
FOR M=0:0
SET M=$ORDER(^TMP($JOB,"*PRO",I,J,K,L,M))
if M=""
QUIT
SET SDINFO=^(M)
DO PNAME
if $Y>(IOSL-5)
DO HD2
if SDFG
QUIT
+2 QUIT
+3 ;
PNAME NEW %
+1 FOR %=1:1:$PIECE(SDINFO,U,4)
WRITE !,?8,$EXTRACT(K,1,18),?28,$PIECE(SDINFO,U,10),?39,"AGE: ",$JUSTIFY($PIECE(SDINFO,U,2),3),?49,$SELECT($PIECE(SDINFO,U)=1:"VETERAN",1:"NON-VET"),?58,$PIECE(SDINFO,U,3),?61
SET VADAT("W")=M
DO ^VADATE
WRITE VADATE("E")
+2 QUIT
+3 ;
+4 ;If prompt "Sort by 'P'rocedure or patient 'N'ame: P//PROCEDURE"
+5 ;CPTMOD is called to print Procedure (CPT) codes and associated
+6 ;Modifiers.
CD NEW BLKLN,MODCODE,MODINFO,MODTEXT,MODVAL,SDJJ,KK,ICPTVDT
+1 SET (BLKLN,MODVAL)=0
SET SDHI=I
if ($Y>(IOSL-5))
DO HD2
if SDFG
QUIT
+2 SET %DT="X"
SET X=SDE
DO ^%DT
SET ICPTVDT=$SELECT(Y<0:DT,1:Y)
+3 ; equals IEN for CPT
SET J=$PIECE($$CPT^ICPTCOD(J,ICPTVDT),"^",1)
+4 ; SD*5.3*339 external CPT value
SET KK=$PIECE($$CPT^ICPTCOD(J,ICPTVDT),"^",2)
+5 ; SD*5.3*339 print external CPT code
WRITE !!,$GET(KK)
+6 SET I=J
DO N
WRITE ?7,$EXTRACT(SDN,1,72)
SET I=SDHI
+7 if 'SDMOD
QUIT
+8 IF $DATA(^TMP($JOB,"*PRO",I,J,0))
SET MODVAL=$PIECE(^TMP($JOB,"*PRO",I,J,0),"^",2,99)
+9 IF $DATA(^TMP($JOB,"*PRO",I,J,1))
SET MODVAL=$PIECE(^TMP($JOB,"*PRO",I,J,1),"^",2,99)
+10 if 'MODVAL
QUIT
+11 FOR SDJJ=1:1:$LENGTH(MODVAL,"^")
SET MODINFO=$PIECE(MODVAL,"^",SDJJ)
Begin DoDot:1
+12 SET MODINFO=$$MOD^ICPTMOD(MODINFO,"I",ICPTVDT,1)
+13 if MODINFO'>0
QUIT
+14 SET MODCODE="-"_$PIECE(MODINFO,"^",2)
+15 SET MODTEXT=$PIECE(MODINFO,"^",3)
+16 WRITE !?2,MODCODE,?8,$EXTRACT(MODTEXT,1,65)
+17 QUIT
End DoDot:1
+18 WRITE !
+19 QUIT
HD2 if SDFG
QUIT
IF IOST?1"C-".E
READ !?20,"Enter <RETURN> to continue",SDFG1:DTIME
IF SDFG1["^"!'$TEST
SET SDFG=1
QUIT
+1 DO HD
WRITE !!?25,"SUMMARY OF PROCEDURES PERFORMED",!
KILL Y
SET $PIECE(Y,"-",81)=""
WRITE Y
QUIT
HD3 if SDFG
QUIT
IF IOST?1"C-".E
READ !?20,"Enter <RETURN> to continue",SDFG1:DTIME
IF SDFG1["^"!'$TEST
SET SDFG=1
QUIT
+1 DO HD
WRITE !!?31,"SUMMARY BY PATIENT",!,"NAME",?27,"SSN",?38,"AGE",?43,"VET/NON",?53,"SEX",?60,"DATE/TIME OF STOP",!
KILL Y
SET $PIECE(Y,"-",81)=""
WRITE Y
SET SET SDT=$SELECT(SDSC="C":I,I="M":"MEDICINE",I="N":"NEUROLOGY",I="P":"PSYCHIATRY",I="R":"REHAB MEDICINE",I="S":"SURGERY",I="Z":"NONE",1:"UNKNOWN")
SET SDFL=1
QUIT
T WRITE !?8,"TOTAL PROCEDURES==>",?30,"VETERAN:",?39,$JUSTIFY($SELECT($DATA(^TMP($JOB,"*PRO",I,J,1)):$PIECE(^(1),"^",1),1:0),4),?47,"NON-VETERAN:",$JUSTIFY($SELECT($DATA(^(0)):$PIECE(^(0),"^",1),1:0),4)
+1 WRITE ?69,"TOTAL:",?76,$JUSTIFY($SELECT($DATA(^TMP($JOB,"*PRO",I,J,0))&$DATA(^(1)):$PIECE(^(0),"^",1)+$PIECE(^(1),"^",1),'$DATA(^(0)):$PIECE(^(1),"^",1),1:$PIECE(^(0),"^",1)),4)
QUIT
C FOR L=-1:0
SET L=$ORDER(^TMP($JOB,"*PTC",I,J,K,L))
if L=""
QUIT
FOR M=0:0
SET M=$ORDER(^TMP($JOB,"*PTC",I,J,K,L,M))
if M=""
QUIT
MERGE SDINFO=^(M)
DO C2
+1 QUIT
C2 ; 10th piece is ssn
WRITE !!,$EXTRACT(J,1,24),?27,$PIECE(SDINFO,U,10)
+1 WRITE ?38,$PIECE(SDINFO,U),?43,$SELECT(L=1:"VETERAN",1:"NON-VET"),?52,$SELECT($PIECE(SDINFO,U,2)="M":" MALE",1:"FEMALE"),?60
SET VADAT("W")=M
DO ^VADATE
WRITE VADATE("E")
DO LIST
+2 QUIT
+3 ;
+4 ;If "Sort by 'P'rocedure or patient 'N'ame: P//NAME" the patient name
+5 ;,Procedure (CPT) Codes and Modifiers will be printed.
LIST NEW BLKLN,MODCODE,MODINFO,MODTEXT,MODVAL,SDJJ,ICPTVDT
+1 SET %DT="X"
SET X=SDE
DO ^%DT
SET ICPTVDT=$SELECT(Y<0:DT,1:Y)
+2 SET BLKLN=1
+3 FOR PR=11:1
SET SDPRO=$PIECE(SDINFO,U,PR)
if 'SDPRO
QUIT
Begin DoDot:1
+4 SET SDHI=I
if ($Y>(IOSL))
DO HD
if SDFG
QUIT
+5 ; SD*5.3*402
WRITE !?5,$PIECE($$CPT^ICPTCOD(SDPRO,ICPTVDT),U,2)
SET I=SDPRO
DO N
+6 WRITE ?12,$EXTRACT(SDN,1,67)
SET I=SDHI
+7 if 'SDMOD
QUIT
+8 SET MODVAL=SDINFO(PR-10)
+9 FOR SDJJ=1:1:$LENGTH(MODVAL,"^")
SET MODINFO=$PIECE(MODVAL,"^",SDJJ)
Begin DoDot:2
+10 SET MODINFO=$$MOD^ICPTMOD(MODINFO,"I",ICPTVDT,1)
+11 if MODINFO'>0
QUIT
+12 SET MODCODE="-"_$PIECE(MODINFO,"^",2)
+13 SET MODTEXT=$PIECE(MODINFO,"^",3)
+14 WRITE !?7,MODCODE,?13,$EXTRACT(MODTEXT,1,65)
+15 QUIT
End DoDot:2
+16 WRITE !
+17 QUIT
End DoDot:1
+18 QUIT
TOT if SDFG
QUIT
KILL I
SET SDT=""
SET SDFL=0
DO P^SDAMBMR3
QUIT
+1 ;
+2 ;Retrieves the Procedure (CPT) Code description by calling API
+3 ;CPTD^ICPTCOD
N NEW DATA,SDIX,SDDATA,SDCOUNT,ICPTVDT
+1 SET %DT="X"
SET X=SDE
DO ^%DT
SET ICPTVDT=$SELECT(Y<0:DT,1:Y)
+2 SET SDN=""
SET DATA=""
+3 ;F S DATA=$O(DESCR(DATA)) Q:'DATA S SDN=SDN_" "_DESCR(DATA) Q:$L(SDN)>72
+4 ;SDDATA will contain the returned information from the call to CPTD^ICPTCOD.
+5 ;This is an extrinsic function, and can't be called with a "Do" statement.
+6 SET SDDATA=$$CPTD^ICPTCOD(I,"DESCR",,ICPTVDT)
+7 SET SDCOUNT=$PIECE(SDDATA,"^",1)
+8 FOR SDIX=1:1:SDCOUNT
SET SDN=SDN_" "_DESCR(SDIX)
if $LENGTH(SDN)>72
QUIT
+9 SET SDN=$EXTRACT(SDN,1,72)
+10 QUIT
