- SDAMBMR1 ;ALB/MLI - AMBULATORY PROCEDURE MANAGEMENT REPORTS ; 4/27/00 10:39am
- ;;5.3;Scheduling;**28,132,180,534**;Aug 13, 1993;Build 8
- S (SDCL,SDT)=$P(SDOE0,U,4) Q:$S('SDT:1,'$D(^SC(SDT,0)):1,1:0)
- D 2^VADPT
- N SDSSN S SDT=$S(SDSC="C":$P(^SC(SDT,0),U),$P(^SC(SDT,0),U,8)]"":$P(^(0),U,8),1:"U"),SDSSN=$P(VADM(2),"^"),VADM(2)=+SDSSN ; save ssn in string format
- S VADM(5)=$S(VADM(5)]"":$P(VADM(5),U),1:"M") S:SDT=0 SDT="Z"
- S SDDIV=$S($P(SDOE0,U,11):$P(SDOE0,U,11),1:$O(^DG(40.8,0)))
- Q:'SDDIV!('VAUTD&'$D(VAUTD(SDDIV)))
- I SDSC="S" Q:'SDAS&'$D(SDS(SDT))
- I SDSC="C" Q:'VAUTC&'$D(VAUTC(SDT))
- ;
- K SDVCPTS
- S SDCT=0
- D GETCPT^SDOE(SDOE,"SDVCPTS")
- S (PROC,SDVCPT)=0
- F S SDVCPT=$O(SDVCPTS(SDVCPT)) Q:'SDVCPT D
- . S X=$G(SDVCPTS(SDVCPT))
- . S SDPR=+X
- . S SDQTY=+$P(X,U,16)
- . IF SDPR]"",$$CPT^ICPTCOD(SDPR,0) S SDCT=SDCT+SDQTY I SDRT="E",SDPN="P",'SDP,'$D(SDP(SDPR)) S SDCT=SDCT-SDQTY
- ;
- Q:'SDCT I SDRT="E",SDPN="N" Q:'VAUTN&'$D(VAUTN(VADM(1)))
- EN S SDVB="SDSX"_$P(VADM(5),U)
- G 1:'$D(^TMP($J,"*PT",VADM(1),VADM(2))),2:'$D(^(VADM(2),VAEL(4))),3:'$D(^TMP($J,"*CL",VADM(2),SDT)),4:'$D(^(SDT,VAEL(4))),5:'$D(^TMP($J,"*DT",VADM(2),$P(SDI,"."))) S SDF=0 D:'$D(^($P(SDI,"."),VAEL(4))) CK
- G 6:SDF,9
- 1 S SDTOT=SDTOT+1,SDAGE=SDAGE+VADM(4),@(SDVB)=(@(SDVB)+1)
- 2 S SDTOT(VAEL(4))=SDTOT(VAEL(4))+1,SDAGE(VAEL(4))=SDAGE(VAEL(4))+VADM(4),@(SDVB_"(VAEL(4))")=@(SDVB_"(VAEL(4))")+1
- I $D(^TMP($J,"*CL",VADM(2),SDT)) G 4:'$D(^(SDT,VAEL(4))),5:'$D(^TMP($J,"*DT",VADM(2),$P(SDI,"."))) S SDF=0 D:'$D(^($P(SDI,"."),VAEL(4))) CK G 6:SDF,9
- 3 S ^("T")=^TMP($J,SDT,"T")+1,^("A")=^TMP($J,SDT,"A")+VADM(4),^("S"_$P(VADM(5),U))=^TMP($J,SDT,"S"_$P(VADM(5),U))+1
- 4 S ^(VAEL(4))=^TMP($J,SDT,"T",VAEL(4))+1,^(VAEL(4))=^TMP($J,SDT,"A",VAEL(4))+VADM(4),^(VAEL(4))=^TMP($J,SDT,"S"_$P(VADM(5),U),VAEL(4))+1 I $D(^TMP($J,"*DT",VADM(2),$P(SDI,"."))) S SDF=0 D:'$D(^($P(SDI,"."),VAEL(4))) CK G 6:SDF,9
- 5 S SDVST=SDVST+1
- 6 S SDVST(VAEL(4))=SDVST(VAEL(4))+1
- 9 S (^TMP($J,"*PT",VADM(1),VADM(2),VAEL(4)),^TMP($J,"*CL",VADM(2),SDT,VAEL(4)),^TMP($J,"*DT",VADM(2),$P(SDI,"."),VAEL(4)))="",SDFL=1 I SDRT="E",SDPN="P",'SDP S SDFL=0
- I SDRT="E",(SDPN="N"),'$D(^TMP($J,"*PTC",SDT,VADM(1),VADM(2),VAEL(4),SDI)) S ^(SDI)=VADM(4)_"^"_VADM(5)_"^^^^^^^^"_SDSSN
- ;
- S (PROC,SDVCPT)=0
- F S SDVCPT=$O(SDVCPTS(SDVCPT)) Q:'SDVCPT D
- . S X=$G(SDVCPTS(SDVCPT))
- . S SDPRO=+X
- . S SDQTY=+$P(X,U,16)
- . I SDPRO]"",$$CPT^ICPTCOD(SDPRO,0) I SDFL!('SDFL&$D(SDP(SDPRO))) S SDPRC(VAEL(4))=SDPRC(VAEL(4))+SDQTY,^(VAEL(4))=^TMP($J,SDT,"PR",VAEL(4))+SDQTY I SDRT="E" D PRO:SDPN="P",NM:SDPN="N"
- S SDSTP=SDSTP+1,SDSTP(VAEL(4))=SDSTP(VAEL(4))+1,^("ST")=^TMP($J,SDT,"ST")+1,^(VAEL(4))=^("ST",VAEL(4))+1
- D KVAR^VADPT Q
- PRO S ^(VAEL(4))=$S($D(^TMP($J,"*PRO",SDT,SDPRO,VAEL(4))):^(VAEL(4))+1,1:SDQTY) I SDPT=1 S ^(SDI)=VAEL(4)_"^"_VADM(4)_"^"_VADM(5)_"^"_$S($D(^(VADM(1),VADM(2),SDI)):$P(^(SDI),U,4)+1,1:1)_"^^^^^^"_SDSSN
- N MODIFIER,PTR
- S PTR=0
- F S PTR=$O(SDVCPTS(SDVCPT,1,PTR)) Q:'PTR D
- . S MODIFIER=$G(SDVCPTS(SDVCPT,1,PTR,0))
- . Q:'MODIFIER
- . S ^(VAEL(4))=^TMP($J,"*PRO",SDT,SDPRO,VAEL(4))_"^"_MODIFIER
- . Q
- Q
- CK I VAEL(4) S SDF=1 I $D(^TMP($J,"*DT",VADM(2),$P(SDI,"."),0)) K ^(0) S SDVST(0)=SDVST(0)-1
- I 'VAEL(4) I '$D(^TMP($J,"*DT",VADM(2),$P(SDI,"."),1)) S SDF=1 Q
- Q
- NM S ^(SDI)=^TMP($J,"*PTC",SDT,VADM(1),VADM(2),VAEL(4),SDI)_"^"_SDPRO
- N MODIFIER,PTR
- S PTR=0,PROC=PROC+1
- S ^TMP($J,"*PTC",SDT,VADM(1),VADM(2),VAEL(4),SDI,PROC)=""
- F S PTR=$O(SDVCPTS(SDVCPT,1,PTR)) Q:'PTR D
- . S MODIFIER=$G(SDVCPTS(SDVCPT,1,PTR,0))
- . Q:'MODIFIER
- . S ^(PROC)=^TMP($J,"*PTC",SDT,VADM(1),VADM(2),VAEL(4),SDI,PROC)_MODIFIER_"^"
- . Q
- Q
- QS W !,"Enter a service or 'return' when all services have been selected" S SDX=$P(^DD(44,9,0),U,3) W !,"Choose from:" F I=1:1:5 S SDI=$P(SDX,";",I) W !,"'",$P(SDI,":",1),"' FOR ",$P(SDI,":",2)
- Q
- NONE W !!,"The ambulatory procedures management reports have run",!,"No matches were found for the following requested information:",! K Y S $P(Y,"-",81)="" W Y D DT^SDAMBMR2 W !!,"DATE RANGE: ",SDB,"-",SDE,!,"DIVISION(S): " W:VAUTD "ALL"
- I 'VAUTD F I=0:0 S I=$O(VAUTD(I)) Q:'I W VAUTD(I),", "
- W !,$S(SDSC="C":"CLINIC(S): ",1:"SERVICE(S): ") W:VAUTC!SDAS "ALL" I '(VAUTC!SDAS) S I=0 F I1=0:0 S I=$S(SDSC="C":$O(VAUTC(I)),1:$O(SDS(I))) Q:'I W:SDSC="C" I,", " I SDSC="S" D SET^SDAMBMR2 W SDT,", "
- Q:SDRT="B" I SDPN="N" W !,"PATIENT(S): " W:VAUTN "ALL" I 'VAUTN S I=0 F I1=0:0 S I=$O(VAUTN(I)) Q:'I W I,", "
- Q:SDPN="N" W !,"PROCEDURE(S): " W:SDP "ALL" I 'SDP S I=0 F S I=$O(SDP(I)) Q:I="" W $P($$CPT^ICPTCOD(I,0),U),", "
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSDAMBMR1 4571 printed Apr 23, 2025@19:01:59 Page 2
- SDAMBMR1 ;ALB/MLI - AMBULATORY PROCEDURE MANAGEMENT REPORTS ; 4/27/00 10:39am
- +1 ;;5.3;Scheduling;**28,132,180,534**;Aug 13, 1993;Build 8
- +2 SET (SDCL,SDT)=$PIECE(SDOE0,U,4)
- if $SELECT('SDT
- QUIT
- +3 DO 2^VADPT
- +4 ; save ssn in string format
- NEW SDSSN
- SET SDT=$SELECT(SDSC="C":$PIECE(^SC(SDT,0),U),$PIECE(^SC(SDT,0),U,8)]"":$PIECE(^(0),U,8),1:"U")
- SET SDSSN=$PIECE(VADM(2),"^")
- SET VADM(2)=+SDSSN
- +5 SET VADM(5)=$SELECT(VADM(5)]"":$PIECE(VADM(5),U),1:"M")
- if SDT=0
- SET SDT="Z"
- +6 SET SDDIV=$SELECT($PIECE(SDOE0,U,11):$PIECE(SDOE0,U,11),1:$ORDER(^DG(40.8,0)))
- +7 if 'SDDIV!('VAUTD&'$DATA(VAUTD(SDDIV)))
- QUIT
- +8 IF SDSC="S"
- if 'SDAS&'$DATA(SDS(SDT))
- QUIT
- +9 IF SDSC="C"
- if 'VAUTC&'$DATA(VAUTC(SDT))
- QUIT
- +10 ;
- +11 KILL SDVCPTS
- +12 SET SDCT=0
- +13 DO GETCPT^SDOE(SDOE,"SDVCPTS")
- +14 SET (PROC,SDVCPT)=0
- +15 FOR
- SET SDVCPT=$ORDER(SDVCPTS(SDVCPT))
- if 'SDVCPT
- QUIT
- Begin DoDot:1
- +16 SET X=$GET(SDVCPTS(SDVCPT))
- +17 SET SDPR=+X
- +18 SET SDQTY=+$PIECE(X,U,16)
- +19 IF SDPR]""
- IF $$CPT^ICPTCOD(SDPR,0)
- SET SDCT=SDCT+SDQTY
- IF SDRT="E"
- IF SDPN="P"
- IF 'SDP
- IF '$DATA(SDP(SDPR))
- SET SDCT=SDCT-SDQTY
- End DoDot:1
- +20 ;
- +21 if 'SDCT
- QUIT
- IF SDRT="E"
- IF SDPN="N"
- if 'VAUTN&'$DATA(VAUTN(VADM(1)))
- QUIT
- EN SET SDVB="SDSX"_$PIECE(VADM(5),U)
- +1 if '$DATA(^TMP($JOB,"*PT",VADM(1),VADM(2)))
- GOTO 1
- if '$DATA(^(VADM(2),VAEL(4)))
- GOTO 2
- if '$DATA(^TMP($JOB,"*CL",VADM(2),SDT))
- GOTO 3
- if '$DATA(^(SDT,VAEL(4)))
- GOTO 4
- if '$DATA(^TMP($JOB,"*DT",VADM(2),$PIECE(SDI,".")))
- GOTO 5
- SET SDF=0
- if '$DATA(^($PIECE(SDI,"."),VAEL(4)))
- DO CK
- +2 if SDF
- GOTO 6
- GOTO 9
- 1 SET SDTOT=SDTOT+1
- SET SDAGE=SDAGE+VADM(4)
- SET @(SDVB)=(@(SDVB)+1)
- 2 SET SDTOT(VAEL(4))=SDTOT(VAEL(4))+1
- SET SDAGE(VAEL(4))=SDAGE(VAEL(4))+VADM(4)
- SET @(SDVB_"(VAEL(4))")=@(SDVB_"(VAEL(4))")+1
- +1 IF $DATA(^TMP($JOB,"*CL",VADM(2),SDT))
- if '$DATA(^(SDT,VAEL(4)))
- GOTO 4
- if '$DATA(^TMP($JOB,"*DT",VADM(2),$PIECE(SDI,".")))
- GOTO 5
- SET SDF=0
- if '$DATA(^($PIECE(SDI,"."),VAEL(4)))
- DO CK
- if SDF
- GOTO 6
- GOTO 9
- 3 SET ^("T")=^TMP($JOB,SDT,"T")+1
- SET ^("A")=^TMP($JOB,SDT,"A")+VADM(4)
- SET ^("S"_$PIECE(VADM(5),U))=^TMP($JOB,SDT,"S"_$PIECE(VADM(5),U))+1
- 4 SET ^(VAEL(4))=^TMP($JOB,SDT,"T",VAEL(4))+1
- SET ^(VAEL(4))=^TMP($JOB,SDT,"A",VAEL(4))+VADM(4)
- SET ^(VAEL(4))=^TMP($JOB,SDT,"S"_$PIECE(VADM(5),U),VAEL(4))+1
- IF $DATA(^TMP($JOB,"*DT",VADM(2),$PIECE(SDI,".")))
- SET SDF=0
- if '$DATA(^($PIECE(SDI,"."),VAEL(4)))
- DO CK
- if SDF
- GOTO 6
- GOTO 9
- 5 SET SDVST=SDVST+1
- 6 SET SDVST(VAEL(4))=SDVST(VAEL(4))+1
- 9 SET (^TMP($JOB,"*PT",VADM(1),VADM(2),VAEL(4)),^TMP($JOB,"*CL",VADM(2),SDT,VAEL(4)),^TMP($JOB,"*DT",VADM(2),$PIECE(SDI,"."),VAEL(4)))=""
- SET SDFL=1
- IF SDRT="E"
- IF SDPN="P"
- IF 'SDP
- SET SDFL=0
- +1 IF SDRT="E"
- IF (SDPN="N")
- IF '$DATA(^TMP($JOB,"*PTC",SDT,VADM(1),VADM(2),VAEL(4),SDI))
- SET ^(SDI)=VADM(4)_"^"_VADM(5)_"^^^^^^^^"_SDSSN
- +2 ;
- +3 SET (PROC,SDVCPT)=0
- +4 FOR
- SET SDVCPT=$ORDER(SDVCPTS(SDVCPT))
- if 'SDVCPT
- QUIT
- Begin DoDot:1
- +5 SET X=$GET(SDVCPTS(SDVCPT))
- +6 SET SDPRO=+X
- +7 SET SDQTY=+$PIECE(X,U,16)
- +8 IF SDPRO]""
- IF $$CPT^ICPTCOD(SDPRO,0)
- IF SDFL!('SDFL&$DATA(SDP(SDPRO)))
- SET SDPRC(VAEL(4))=SDPRC(VAEL(4))+SDQTY
- SET ^(VAEL(4))=^TMP($JOB,SDT,"PR",VAEL(4))+SDQTY
- IF SDRT="E"
- if SDPN="P"
- DO PRO
- if SDPN="N"
- DO NM
- End DoDot:1
- +9 SET SDSTP=SDSTP+1
- SET SDSTP(VAEL(4))=SDSTP(VAEL(4))+1
- SET ^("ST")=^TMP($JOB,SDT,"ST")+1
- SET ^(VAEL(4))=^("ST",VAEL(4))+1
- +10 DO KVAR^VADPT
- QUIT
- PRO SET ^(VAEL(4))=$SELECT($DATA(^TMP($JOB,"*PRO",SDT,SDPRO,VAEL(4))):^(VAEL(4))+1,1:SDQTY)
- IF SDPT=1
- SET ^(SDI)=VAEL(4)_"^"_VADM(4)_"^"_VADM(5)_"^"_$SELECT($DATA(^(VADM(1),VADM(2),SDI)):$PIECE(^(SDI),U,4)+1,1:1)_"^^^^^^"_SDSSN
- +1 NEW MODIFIER,PTR
- +2 SET PTR=0
- +3 FOR
- SET PTR=$ORDER(SDVCPTS(SDVCPT,1,PTR))
- if 'PTR
- QUIT
- Begin DoDot:1
- +4 SET MODIFIER=$GET(SDVCPTS(SDVCPT,1,PTR,0))
- +5 if 'MODIFIER
- QUIT
- +6 SET ^(VAEL(4))=^TMP($JOB,"*PRO",SDT,SDPRO,VAEL(4))_"^"_MODIFIER
- +7 QUIT
- End DoDot:1
- +8 QUIT
- CK IF VAEL(4)
- SET SDF=1
- IF $DATA(^TMP($JOB,"*DT",VADM(2),$PIECE(SDI,"."),0))
- KILL ^(0)
- SET SDVST(0)=SDVST(0)-1
- +1 IF 'VAEL(4)
- IF '$DATA(^TMP($JOB,"*DT",VADM(2),$PIECE(SDI,"."),1))
- SET SDF=1
- QUIT
- +2 QUIT
- NM SET ^(SDI)=^TMP($JOB,"*PTC",SDT,VADM(1),VADM(2),VAEL(4),SDI)_"^"_SDPRO
- +1 NEW MODIFIER,PTR
- +2 SET PTR=0
- SET PROC=PROC+1
- +3 SET ^TMP($JOB,"*PTC",SDT,VADM(1),VADM(2),VAEL(4),SDI,PROC)=""
- +4 FOR
- SET PTR=$ORDER(SDVCPTS(SDVCPT,1,PTR))
- if 'PTR
- QUIT
- Begin DoDot:1
- +5 SET MODIFIER=$GET(SDVCPTS(SDVCPT,1,PTR,0))
- +6 if 'MODIFIER
- QUIT
- +7 SET ^(PROC)=^TMP($JOB,"*PTC",SDT,VADM(1),VADM(2),VAEL(4),SDI,PROC)_MODIFIER_"^"
- +8 QUIT
- End DoDot:1
- +9 QUIT
- QS WRITE !,"Enter a service or 'return' when all services have been selected"
- SET SDX=$PIECE(^DD(44,9,0),U,3)
- WRITE !,"Choose from:"
- FOR I=1:1:5
- SET SDI=$PIECE(SDX,";",I)
- WRITE !,"'",$PIECE(SDI,":",1),"' FOR ",$PIECE(SDI,":",2)
- +1 QUIT
- NONE WRITE !!,"The ambulatory procedures management reports have run",!,"No matches were found for the following requested information:",!
- KILL Y
- SET $PIECE(Y,"-",81)=""
- WRITE Y
- DO DT^SDAMBMR2
- WRITE !!,"DATE RANGE: ",SDB,"-",SDE,!,"DIVISION(S): "
- if VAUTD
- WRITE "ALL"
- +1 IF 'VAUTD
- FOR I=0:0
- SET I=$ORDER(VAUTD(I))
- if 'I
- QUIT
- WRITE VAUTD(I),", "
- +2 WRITE !,$SELECT(SDSC="C":"CLINIC(S): ",1:"SERVICE(S): ")
- if VAUTC!SDAS
- WRITE "ALL"
- IF '(VAUTC!SDAS)
- SET I=0
- FOR I1=0:0
- SET I=$SELECT(SDSC="C":$ORDER(VAUTC(I)),1:$ORDER(SDS(I)))
- if 'I
- QUIT
- if SDSC="C"
- WRITE I,", "
- IF SDSC="S"
- DO SET^SDAMBMR2
- WRITE SDT,", "
- +3 if SDRT="B"
- QUIT
- IF SDPN="N"
- WRITE !,"PATIENT(S): "
- if VAUTN
- WRITE "ALL"
- IF 'VAUTN
- SET I=0
- FOR I1=0:0
- SET I=$ORDER(VAUTN(I))
- if 'I
- QUIT
- WRITE I,", "
- +4 if SDPN="N"
- QUIT
- WRITE !,"PROCEDURE(S): "
- if SDP
- WRITE "ALL"
- IF 'SDP
- SET I=0
- FOR
- SET I=$ORDER(SDP(I))
- if I=""
- QUIT
- WRITE $PIECE($$CPT^ICPTCOD(I,0),U),", "
- +5 QUIT
