ECXUCPT ;ALB/TJL-CPT INQUIRY FOR MYSTERY FEEDER KEYS ;10/22/13 17:32
;;3.0;DSS EXTRACTS;**49,123,148**;Dec 22, 1997;Build 3
;
EN ; entry point
N X,Y,DATE,ECRUN,QFLG
S QFLG=0
; get today's date
D NOW^%DTC S DATE=X,Y=$E(%,1,12) D DD^%DT S ECRUN=$P(Y,"@") K %DT
D BEGIN
F D SELECT W @IOF Q:QFLG
Q
;
BEGIN ; display report description
W @IOF
W !,"This inquiry allows the user to select a CPT code, then displays"
W !,"the Short Name, Category, and Description for the selected code."
W !!
Q
;
SELECT ; user inputs for CPT Code
N OUT,DIC,X,Y,DIR,CIEN,ECXARR,ECXIEN
S DIC="^ICPT(",DIC(0)="AZEMQ" D ^DIC
I Y<0 S QFLG=1 Q
S ECXIEN=+Y
S ECXARR=$$CPT^ICPTCOD(ECXIEN) I +ECXARR=-1 W !,"CPT Code Error." S QFLG=1 Q
S CIEN=$P(ECXARR,U,4) I CIEN S ECXARR(81.1)=$$GET1^DIQ(81.1,CIEN_",",.01)
S X=$$CPTD^ICPTCOD(ECXIEN,"ECXARR(81.01,")
D PRINT
S DIR(0)="E" W ! D ^DIR K DIR I 'Y S QFLG=1
Q
;
PRINT ; display results of inquiry
N LN,DESCDA
S $P(LN,"-",80)=""
W !!,"CPT Inquiry",?54,"Date: ",ECRUN,!,LN,!
W !,"CPT Code: ",$P(ECXARR,U,2)
W ?30,"Short Name: ",$P(ECXARR,U,3)
W !!,"Category: ",$G(ECXARR(81.1))
W !!,"Description: "
F DESCDA=1:1 Q:'$D(ECXARR(81.01,DESCDA)) D
.W ECXARR(81.01,DESCDA),!
W !!!
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HECXUCPT 1276 printed Dec 13, 2024@01:54:13 Page 2
ECXUCPT ;ALB/TJL-CPT INQUIRY FOR MYSTERY FEEDER KEYS ;10/22/13 17:32
+1 ;;3.0;DSS EXTRACTS;**49,123,148**;Dec 22, 1997;Build 3
+2 ;
EN ; entry point
+1 NEW X,Y,DATE,ECRUN,QFLG
+2 SET QFLG=0
+3 ; get today's date
+4 DO NOW^%DTC
SET DATE=X
SET Y=$EXTRACT(%,1,12)
DO DD^%DT
SET ECRUN=$PIECE(Y,"@")
KILL %DT
+5 DO BEGIN
+6 FOR
DO SELECT
WRITE @IOF
if QFLG
QUIT
+7 QUIT
+8 ;
BEGIN ; display report description
+1 WRITE @IOF
+2 WRITE !,"This inquiry allows the user to select a CPT code, then displays"
+3 WRITE !,"the Short Name, Category, and Description for the selected code."
+4 WRITE !!
+5 QUIT
+6 ;
SELECT ; user inputs for CPT Code
+1 NEW OUT,DIC,X,Y,DIR,CIEN,ECXARR,ECXIEN
+2 SET DIC="^ICPT("
SET DIC(0)="AZEMQ"
DO ^DIC
+3 IF Y<0
SET QFLG=1
QUIT
+4 SET ECXIEN=+Y
+5 SET ECXARR=$$CPT^ICPTCOD(ECXIEN)
IF +ECXARR=-1
WRITE !,"CPT Code Error."
SET QFLG=1
QUIT
+6 SET CIEN=$PIECE(ECXARR,U,4)
IF CIEN
SET ECXARR(81.1)=$$GET1^DIQ(81.1,CIEN_",",.01)
+7 SET X=$$CPTD^ICPTCOD(ECXIEN,"ECXARR(81.01,")
+8 DO PRINT
+9 SET DIR(0)="E"
WRITE !
DO ^DIR
KILL DIR
IF 'Y
SET QFLG=1
+10 QUIT
+11 ;
PRINT ; display results of inquiry
+1 NEW LN,DESCDA
+2 SET $PIECE(LN,"-",80)=""
+3 WRITE !!,"CPT Inquiry",?54,"Date: ",ECRUN,!,LN,!
+4 WRITE !,"CPT Code: ",$PIECE(ECXARR,U,2)
+5 WRITE ?30,"Short Name: ",$PIECE(ECXARR,U,3)
+6 WRITE !!,"Category: ",$GET(ECXARR(81.1))
+7 WRITE !!,"Description: "
+8 FOR DESCDA=1:1
if '$DATA(ECXARR(81.01,DESCDA))
QUIT
Begin DoDot:1
+9 WRITE ECXARR(81.01,DESCDA),!
End DoDot:1
+10 WRITE !!!
+11 QUIT
+12 ;
