Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: ECXUCPT

ECXUCPT.m

Go to the documentation of this file.
  1. 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
  1. ;
  1. EN ; entry point
  1. N X,Y,DATE,ECRUN,QFLG
  1. S QFLG=0
  1. ; get today's date
  1. D NOW^%DTC S DATE=X,Y=$E(%,1,12) D DD^%DT S ECRUN=$P(Y,"@") K %DT
  1. D BEGIN
  1. F D SELECT W @IOF Q:QFLG
  1. Q
  1. ;
  1. BEGIN ; display report description
  1. W @IOF
  1. W !,"This inquiry allows the user to select a CPT code, then displays"
  1. W !,"the Short Name, Category, and Description for the selected code."
  1. W !!
  1. Q
  1. ;
  1. SELECT ; user inputs for CPT Code
  1. N OUT,DIC,X,Y,DIR,CIEN,ECXARR,ECXIEN
  1. S DIC="^ICPT(",DIC(0)="AZEMQ" D ^DIC
  1. I Y<0 S QFLG=1 Q
  1. S ECXIEN=+Y
  1. S ECXARR=$$CPT^ICPTCOD(ECXIEN) I +ECXARR=-1 W !,"CPT Code Error." S QFLG=1 Q
  1. S CIEN=$P(ECXARR,U,4) I CIEN S ECXARR(81.1)=$$GET1^DIQ(81.1,CIEN_",",.01)
  1. S X=$$CPTD^ICPTCOD(ECXIEN,"ECXARR(81.01,")
  1. D PRINT
  1. S DIR(0)="E" W ! D ^DIR K DIR I 'Y S QFLG=1
  1. Q
  1. ;
  1. PRINT ; display results of inquiry
  1. N LN,DESCDA
  1. S $P(LN,"-",80)=""
  1. W !!,"CPT Inquiry",?54,"Date: ",ECRUN,!,LN,!
  1. W !,"CPT Code: ",$P(ECXARR,U,2)
  1. W ?30,"Short Name: ",$P(ECXARR,U,3)
  1. W !!,"Category: ",$G(ECXARR(81.1))
  1. W !!,"Description: "
  1. F DESCDA=1:1 Q:'$D(ECXARR(81.01,DESCDA)) D
  1. .W ECXARR(81.01,DESCDA),!
  1. W !!!
  1. Q
  1. ;