- SCRPW241 ;BPCIOFO/ACS - ACRP Ad Hoc Report (cont.) ;06/30/99
- ;;5.3;Scheduling;**180,254,351,1015**;AUG 13, 1993;Build 21
- ;
- ;----------------------------------------------------------------
- ; 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
- SCRPW241 ;BPCIOFO/ACS - ACRP Ad Hoc Report (cont.) ;06/30/99
- +1 ;;5.3;Scheduling;**180,254,351,1015**;AUG 13, 1993;Build 21
- +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
