SCRPW241 ;BPCIOFO/ACS - ACRP Ad Hoc Report (cont.) ;06/30/99
;;5.3;Scheduling;**180,254,351**;AUG 13, 1993
;
;----------------------------------------------------------------
; This routine was created due to the max number of bytes
; being reached in SCRPW24
;
; This routine is called by SCRPW24, and it contains CPT API calls
;
;----------------------------------------------------------------
;
APAC(SDX) ;Get all procedure codes
; INPUT - .SDX array reference
; OUTPUT- SDX array with CPT pointer, CPT code, quantity
;
K SDX
N SDY,SDI,CPTINFO,CPTCODE
; array SDY will contain the CPT information
D GETCPT^SDOE(SDOE,"SDY")
; Spin through CPT array and get CPT code and quantity
S SDI=0 F S SDI=$O(SDY(SDI)) Q:'SDI D
. I $D(SDY(SDI,0)) S SDX=$P(SDY(SDI,0),U)
. E Q
. S CPTINFO=$$CPT^ICPTCOD(+SDX,+SDOE0,1)
. Q:CPTINFO'>0
. S CPTCODE=$P(CPTINFO,U,2)
. S SDX=SDX_U_CPTCODE_U_$P(SDY(SDI,0),U,16)
. I $L($P(SDX,U,2)) D APOTR(.SDX) S SDX(SDI)=SDX
. Q
Q
;
APOTR(SDX) ;Transform procedure external value
; INPUT - .SDX CPT pointer
; OUTPUT- SDX text string containing CPT code, CPT text
;
N CPTINFO,CPTTEXT,ENCDT
S ENCDT=+$G(SDOE0)
I 'ENCDT D
.I '$G(SDOE) S ENCDT=$$NOW^XLFDT() Q
.D GETGEN^SDOE(SDOE,"SDY")
.S ENCDT=+$G(SDY(0))
.K SDY
S CPTINFO=$$CPT^ICPTCOD(+SDX,ENCDT,1)
Q:CPTINFO'>0
S CPTTEXT=$P(CPTINFO,U,3)
S $P(SDX,U,2)=$P(SDX,U,2)_" "_CPTTEXT
Q
;
APAP(SDX) ;Get ambulatory procedures (no E&M codes)
; INPUT - .SDX array reference
; OUTPUT- SDX array containing CPT pointer, CPT code, CPT text
;
K SDX
N SDY,SDI,CPTINFO,CPTCODE
D GETCPT^SDOE(SDOE,"SDY")
; Spin through CPT array and get CPT code
S SDI=0 F S SDI=$O(SDY(SDI)) Q:'SDI D
. I $D(SDY(SDI,0)) S SDX=$P(SDY(SDI,0),U)
. E Q
. I '$D(^IBE(357.69,"B",SDX)) D
.. S CPTINFO=$$CPT^ICPTCOD(+SDX,+SDOE0,1)
.. Q:CPTINFO'>0
.. S CPTCODE=$P(CPTINFO,U,2)
.. S SDX=SDX_U_CPTCODE
.. I $L($P(SDX,U,2)) D APOTR(.SDX) S SDX(SDI)=SDX
.. Q
. Q
Q
;
APEM(SDX) ;Get evaluation and management codes
; INPUT - .SDX array reference
; OUTPUT- SDX array containing CPT pointer, CPT code, CPT text
;
K SDX
N SDY,SDI,CPTINFO,CPTCODE
D GETCPT^SDOE(SDOE,"SDY")
; Spin through CPT array and get CPT code
S SDI=0 F S SDI=$O(SDY(SDI)) Q:'SDI D
. I $D(SDY(SDI,0)) S SDX=$P(SDY(SDI,0),U)
. E Q
. I $D(^IBE(357.69,"B",SDX)) D
.. S CPTINFO=$$CPT^ICPTCOD(+SDX,+SDOE0,1)
.. Q:CPTINFO'>0
.. S CPTCODE=$P(CPTINFO,U,2)
.. S SDX=SDX_U_CPTCODE
.. I $L($P(SDX,U,2)) D APOTR(.SDX) S SDX(SDI)=SDX
.. Q
. Q
Q
;
PDPE(SDX) ;Get patient's ethnicities
K SDX
N DFN,VADM,NUM,CNT,ABB,TXT
S DFN=$P(SDOE0,U,2)
I DFN D DEM^VADPT I VADM(11) S CNT=1,NUM=0 F S NUM=+$O(VADM(11,NUM)) Q:'NUM D
.I VADM(11,NUM) D
..S TXT=$$PTR2TEXT^DGUTL4(+VADM(11,NUM),2) S:TXT="" TXT="?"
..S ABB=$$PTR2CODE^DGUTL4(+$G(VADM(11,NUM,1)),3,1) S:ABB="" ABB="?"
..S SDX(CNT)=+VADM(11,NUM)_"^"_TXT_" ("_ABB_")",CNT=CNT+1
S:$D(SDX)<10 SDX(1)="~~~NONE~~~^~~~UNANSWERED~~~"
Q
;
PDPR(SDX) ;Get patient's race
K SDX
N DFN,VADM,NUM,CNT,ABB,TXT
S DFN=$P(SDOE0,U,2)
I DFN D DEM^VADPT I VADM(12) S CNT=1,NUM=0 F S NUM=+$O(VADM(12,NUM)) Q:'NUM D
.I VADM(12,NUM) D
..S TXT=$$PTR2TEXT^DGUTL4(+VADM(12,NUM),1) S:TXT="" TXT="?"
..S ABB=$$PTR2CODE^DGUTL4(+$G(VADM(12,NUM,1)),3,1) S:ABB="" ABB="?"
..S SDX(CNT)=+VADM(12,NUM)_"^"_TXT_" ("_ABB_")",CNT=CNT+1
S:$D(SDX)<10 SDX(1)="~~~NONE~~~^~~~UNANSWERED~~~"
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSCRPW241 3521 printed Dec 13, 2024@02:43:28 Page 2
SCRPW241 ;BPCIOFO/ACS - ACRP Ad Hoc Report (cont.) ;06/30/99
+1 ;;5.3;Scheduling;**180,254,351**;AUG 13, 1993
+2 ;
+3 ;----------------------------------------------------------------
+4 ; This routine was created due to the max number of bytes
+5 ; being reached in SCRPW24
+6 ;
+7 ; This routine is called by SCRPW24, and it contains CPT API calls
+8 ;
+9 ;----------------------------------------------------------------
+10 ;
APAC(SDX) ;Get all procedure codes
+1 ; INPUT - .SDX array reference
+2 ; OUTPUT- SDX array with CPT pointer, CPT code, quantity
+3 ;
+4 KILL SDX
+5 NEW SDY,SDI,CPTINFO,CPTCODE
+6 ; array SDY will contain the CPT information
+7 DO GETCPT^SDOE(SDOE,"SDY")
+8 ; Spin through CPT array and get CPT code and quantity
+9 SET SDI=0
FOR
SET SDI=$ORDER(SDY(SDI))
if 'SDI
QUIT
Begin DoDot:1
+10 IF $DATA(SDY(SDI,0))
SET SDX=$PIECE(SDY(SDI,0),U)
+11 IF '$TEST
QUIT
+12 SET CPTINFO=$$CPT^ICPTCOD(+SDX,+SDOE0,1)
+13 if CPTINFO'>0
QUIT
+14 SET CPTCODE=$PIECE(CPTINFO,U,2)
+15 SET SDX=SDX_U_CPTCODE_U_$PIECE(SDY(SDI,0),U,16)
+16 IF $LENGTH($PIECE(SDX,U,2))
DO APOTR(.SDX)
SET SDX(SDI)=SDX
+17 QUIT
End DoDot:1
+18 QUIT
+19 ;
APOTR(SDX) ;Transform procedure external value
+1 ; INPUT - .SDX CPT pointer
+2 ; OUTPUT- SDX text string containing CPT code, CPT text
+3 ;
+4 NEW CPTINFO,CPTTEXT,ENCDT
+5 SET ENCDT=+$GET(SDOE0)
+6 IF 'ENCDT
Begin DoDot:1
+7 IF '$GET(SDOE)
SET ENCDT=$$NOW^XLFDT()
QUIT
+8 DO GETGEN^SDOE(SDOE,"SDY")
+9 SET ENCDT=+$GET(SDY(0))
+10 KILL SDY
End DoDot:1
+11 SET CPTINFO=$$CPT^ICPTCOD(+SDX,ENCDT,1)
+12 if CPTINFO'>0
QUIT
+13 SET CPTTEXT=$PIECE(CPTINFO,U,3)
+14 SET $PIECE(SDX,U,2)=$PIECE(SDX,U,2)_" "_CPTTEXT
+15 QUIT
+16 ;
APAP(SDX) ;Get ambulatory procedures (no E&M codes)
+1 ; INPUT - .SDX array reference
+2 ; OUTPUT- SDX array containing CPT pointer, CPT code, CPT text
+3 ;
+4 KILL SDX
+5 NEW SDY,SDI,CPTINFO,CPTCODE
+6 DO GETCPT^SDOE(SDOE,"SDY")
+7 ; Spin through CPT array and get CPT code
+8 SET SDI=0
FOR
SET SDI=$ORDER(SDY(SDI))
if 'SDI
QUIT
Begin DoDot:1
+9 IF $DATA(SDY(SDI,0))
SET SDX=$PIECE(SDY(SDI,0),U)
+10 IF '$TEST
QUIT
+11 IF '$DATA(^IBE(357.69,"B",SDX))
Begin DoDot:2
+12 SET CPTINFO=$$CPT^ICPTCOD(+SDX,+SDOE0,1)
+13 if CPTINFO'>0
QUIT
+14 SET CPTCODE=$PIECE(CPTINFO,U,2)
+15 SET SDX=SDX_U_CPTCODE
+16 IF $LENGTH($PIECE(SDX,U,2))
DO APOTR(.SDX)
SET SDX(SDI)=SDX
+17 QUIT
End DoDot:2
+18 QUIT
End DoDot:1
+19 QUIT
+20 ;
APEM(SDX) ;Get evaluation and management codes
+1 ; INPUT - .SDX array reference
+2 ; OUTPUT- SDX array containing CPT pointer, CPT code, CPT text
+3 ;
+4 KILL SDX
+5 NEW SDY,SDI,CPTINFO,CPTCODE
+6 DO GETCPT^SDOE(SDOE,"SDY")
+7 ; Spin through CPT array and get CPT code
+8 SET SDI=0
FOR
SET SDI=$ORDER(SDY(SDI))
if 'SDI
QUIT
Begin DoDot:1
+9 IF $DATA(SDY(SDI,0))
SET SDX=$PIECE(SDY(SDI,0),U)
+10 IF '$TEST
QUIT
+11 IF $DATA(^IBE(357.69,"B",SDX))
Begin DoDot:2
+12 SET CPTINFO=$$CPT^ICPTCOD(+SDX,+SDOE0,1)
+13 if CPTINFO'>0
QUIT
+14 SET CPTCODE=$PIECE(CPTINFO,U,2)
+15 SET SDX=SDX_U_CPTCODE
+16 IF $LENGTH($PIECE(SDX,U,2))
DO APOTR(.SDX)
SET SDX(SDI)=SDX
+17 QUIT
End DoDot:2
+18 QUIT
End DoDot:1
+19 QUIT
+20 ;
PDPE(SDX) ;Get patient's ethnicities
+1 KILL SDX
+2 NEW DFN,VADM,NUM,CNT,ABB,TXT
+3 SET DFN=$PIECE(SDOE0,U,2)
+4 IF DFN
DO DEM^VADPT
IF VADM(11)
SET CNT=1
SET NUM=0
FOR
SET NUM=+$ORDER(VADM(11,NUM))
if 'NUM
QUIT
Begin DoDot:1
+5 IF VADM(11,NUM)
Begin DoDot:2
+6 SET TXT=$$PTR2TEXT^DGUTL4(+VADM(11,NUM),2)
if TXT=""
SET TXT="?"
+7 SET ABB=$$PTR2CODE^DGUTL4(+$GET(VADM(11,NUM,1)),3,1)
if ABB=""
SET ABB="?"
+8 SET SDX(CNT)=+VADM(11,NUM)_"^"_TXT_" ("_ABB_")"
SET CNT=CNT+1
End DoDot:2
End DoDot:1
+9 if $DATA(SDX)<10
SET SDX(1)="~~~NONE~~~^~~~UNANSWERED~~~"
+10 QUIT
+11 ;
PDPR(SDX) ;Get patient's race
+1 KILL SDX
+2 NEW DFN,VADM,NUM,CNT,ABB,TXT
+3 SET DFN=$PIECE(SDOE0,U,2)
+4 IF DFN
DO DEM^VADPT
IF VADM(12)
SET CNT=1
SET NUM=0
FOR
SET NUM=+$ORDER(VADM(12,NUM))
if 'NUM
QUIT
Begin DoDot:1
+5 IF VADM(12,NUM)
Begin DoDot:2
+6 SET TXT=$$PTR2TEXT^DGUTL4(+VADM(12,NUM),1)
if TXT=""
SET TXT="?"
+7 SET ABB=$$PTR2CODE^DGUTL4(+$GET(VADM(12,NUM,1)),3,1)
if ABB=""
SET ABB="?"
+8 SET SDX(CNT)=+VADM(12,NUM)_"^"_TXT_" ("_ABB_")"
SET CNT=CNT+1
End DoDot:2
End DoDot:1
+9 if $DATA(SDX)<10
SET SDX(1)="~~~NONE~~~^~~~UNANSWERED~~~"
+10 QUIT
