- 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 Feb 18, 2025@23:20:37 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 ;