- SDAMBMR2 ;ALB/MLI - PRINT AMBULATORY PROCEDURES MANAGEMENT REPORTS ; 4/27/00 12:14pm
- ;;5.3;Scheduling;**28,140,132,180,339,387,402,1015**;Aug 13, 1993;Build 21
- 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
- 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
- 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