source: WorldVistAEHR/trunk/r/DSS_EXTRACTS-ECX/ECXFEKE1.m@ 701

Last change on this file since 701 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR

File size: 5.4 KB
Line 
1ECXFEKE1 ;BIR/DMA,CML-Print Feeder Keys (CONTINUED); [ 03/28/96 5:44 PM ] ; 4/3/02 2:45pm
2 ;;3.0;DSS EXTRACTS;**11,8,40**;Dec 22, 1997
3 ;
4SELLABKE() ;** Function to prompt user selection of type of Lab Feeder Key
5 ;
6 ;** Variable Definitions
7 ;** ECXKEY - Value of user selection returned to calling code
8 ;** Returns N - LMIP Code formated feeder keys
9 ;** O - Locally formated feeder keys
10 ;** -1 - User uparrow (^) or Time out
11 ;
12 N ECXKEY
13 W !!,"The Feeder Key List for the Feeder System LAB can be printed by:"
14 W !,?5,"(O)ld Feeder Key sort by Local Feeder Key values"
15 W !,?5,"(N)ew Feeder Key sort by LMIP Codes"
16 S DIR(0)="S^O:OLD;N:NEW"
17 S:$D(^ECX(728,1,"LMIP")) DIR("B")="NEW"
18 S:'$D(^ECX(728,1,"LMIP")) DIR("B")="OLD"
19 D ^DIR
20 S:$D(DIRUT) ECXKEY=-1
21 S:'$D(DIRUT) ECXKEY=Y
22 K Y,DIR,DIRUT,DTOUT,DUOUT
23 Q ECXKEY
24 ;
25SUR F EC=1:1:16 S EC1=$P($T(@("S"_EC)),";",3),EC2=$P(EC1,U),ECD=$P(EC1,U,2),^TMP($J,"SUR",EC2_"-10",EC)=ECD_" PATIENT TIME",^TMP($J,"SUR",EC2_"-40",EC)=ECD_" SURGEON TIME" D
26 .S ^TMP($J,"SUR",EC2_"-60",EC)=ECD_" RECOVERY ROOM TIME",^TMP($J,"SUR",EC2_"-70",EC)=ECD_" TECHNICIAN TIME",^TMP($J,"SUR",EC2_"-30",EC)=ECD_" CLEANUP TIME"
27 .S ^TMP($J,"SUR",EC2_"-22",1)=ECD_" ANESTHESIA TIME (SPECIAL)"
28 .S ^TMP($J,"SUR",EC2_"-21",1)=ECD_" ANESTHESIA TIME (GENERAL)"
29 .S ^TMP($J,"SUR",EC2_"-23",1)=ECD_" ANESTHESIA TIME (LOCAL)"
30 .S ^TMP($J,"SUR",EC2_"-24",1)=ECD_" ANESTHESIA TIME (SPI/EPI)"
31 .S ^TMP($J,"SUR",EC2_"-25",1)=ECD_" ANESTHESIA TIME (OTHER)"
32 .S ^TMP($J,"SUR",EC2_"-26",1)=ECD_" ANESTHESIA TIME (UNKNOWN)"
33 .S ^TMP($J,"SUR",EC2_"-27",1)=ECD_" ANESTHESIA TIME (MONITORED)"
34 S EC=0 F S EC=$O(^SRO(131.9,EC)) Q:'EC I $D(^(EC,0)) S ECD=$P(^(0),U),^TMP($J,"SUR",$$RJ^XLFSTR(EC,5,0),EC)=ECD
35 Q
36S1 ;;050^GENERAL(OR WHEN NOT DEFINED BELOW)
37S2 ;;051^GYNECOLOGY
38S3 ;;052^NEUROSURGERY
39S4 ;;053^OPHTHALMOLOGY
40S5 ;;054^ORTHOPEDICS
41S6 ;;055^OTORHINOLARYNGOLOGY (ENT)
42S7 ;;056^PLASTIC SURGERY (INCLUDES HEAD AND NECK)
43S8 ;;057^PROCTOLOGY
44S9 ;;058^THORACIC SURGERY (INC. CARDIAC SURG.)
45S10 ;;059^UROLOGY
46S11 ;;060^ORAL SURGERY (DENTAL)
47S12 ;;061^PODIATRY
48S13 ;;062^PERIPHERAL VASCULAR
49S14 ;;500^CARDIAC SURGERY
50S15 ;;501^TRANSPLANTATION
51S16 ;;502^ANESTHESIOLOGY
52 ;
53DEN F EC=3:1 S EC1=$T(DEN+EC) Q:EC1'?1"D"2N.E S ECD=$P(EC1,";",3),EC1=$P(EC1," "),^TMP($J,"DEN",EC1,EC)=ECD
54 Q
55 ;
56D08C ;;COMPLETE EXAM
57D08S ;;SCREENING EXAM
58D09 ;;ADMIN PROCEDURE
59D10 ;;X-RAYS EXTRAORAL #
60D11 ;;X-RAYS INTRAORAL #
61D12 ;;PROPHY NATURAL DENTITION
62D13 ;;PROPHY DENTURE
63D14 ;;OPERATING ROOM
64D15 ;;NEOPLASM CONFIRMED MALIGNANT #
65D16 ;;NEOPLASM REMOVED #
66D17 ;;BIOPSY/SMEAR #
67D18 ;;FRACTURE #
68D20 ;;OTHER SIGNIF. SURG. (CTV)
69D21 ;;SURFACES RESTORED #
70D22 ;;ROOT CANAL THERAPY #
71D23 ;;PERIDONTAL QUADS (SURGICAL) #
72D24 ;;PERIO QUADS (ROOT PLANE) #
73D25G ;;PATIENT ED (CTV) GROUP
74D25I ;;PATIENT ED (CTV) INDIVIDUAL
75D26S ;;SPOT CHECK EXAM (STAFF)
76D26F ;;SPOT CHECK EXAM (FEE)
77D27 ;;INDIVIDUAL CROWNS #
78D28 ;;POST & CORES #
79D29 ;;FIXED PARTIALS (ABUT) #
80D30 ;;FIXED PARTIALS (PONT ONLY) #
81D31 ;;REMOVABLE PARTIALS #
82D32 ;;COMPLETE DENTURES #
83D33 ;;PROSTHETIC REPAIR #
84D34 ;;SPLINT AND SPEC. PROCESS (CTV)
85D35 ;;EXTRACTIONS #
86D36 ;;SURGICAL EXTRACTIONS #
87D37 ;;OTHER SIG TREATMENT (CTV)
88D38 ;;DIVISION (STATION DIVISION)
89D39C ;;COMPLETIONS
90D39T ;;TERMINATIONS
91D40 ;;INTERDISCIPLINARY CONSULT
92D41 ;;EVALUATIONS
93D42 ;;PRE AUTHORIZATION/2ND OPINION
94D43M ;;SPOT CHECK DISCREPANCY (STAFF)
95D43R ;;SPOT CHECK DISCREPANCY (FEE)
96 ;
97PRINT ;
98 ;setting EC9=EC1 is just for the benefit of the new ECS feeder key list - don't want to mess-up the other lists
99 S (QFLG,PG)=0,$P(LN,"-",81)=""
100 S EC="" F S EC=$O(^TMP($J,EC)),EC1="" Q:EC="" Q:QFLG D HEAD F S EC1=$O(^TMP($J,EC,EC1)),EC9=EC1,EC2="" Q:EC1="" Q:QFLG D
101 .I EC="CLI" S EC9=$P(EC9,";",2)
102 .I EC="ECS",$G(ECECS)="N" S EC9=$P(EC9,";",2)
103 .I EC="LAB",EC9[".8" S EC9=$$ADD0(EC9)
104 .F S EC2=$O(^TMP($J,EC,EC1,EC2)) Q:EC2="" D
105 ..D:($Y+3>IOSL) HEAD Q:QFLG
106 ..I EC="PHA" W !,?2,$E(EC9,2,99),?24,$E($P(^TMP($J,EC,EC1,EC2),U),1,40),?67,$$RJ^XLFSTR($P(^(EC2),U,2),12) Q
107 ..W !,?5,EC9,?27,^TMP($J,EC,EC1,EC2)
108 I $E(IOST)="C"&('QFLG) S DIR(0)="E" D D ^DIR K DIR
109 .S SS=22-$Y F JJ=1:1:SS W !
110 K EC,EC1,EC2,EC3,EC9,ECCSC,ECD,ECLIST,ECNDC,ECNDF,ECNFC,ECPHA,ECECS,ECLAB,ECSC,ECST,ECY,JJ,LN,P1,P2,P3,PG,POP,QFLG,SC,SS,X,Y,^TMP($J),DIR,DIRUT,DUOUT
111 W:$E(IOST)'="C" @IOF D ^%ZISC S:$D(ZTQUEUED) ZTREQ="@"
112 Q
113HEAD ;
114 I $E(IOST)="C" S SS=22-$Y F JJ=1:1:SS W !
115 I $E(IOST)="C",PG>0 S DIR(0)="E" D ^DIR K DIR I 'Y S QFLG=1 Q
116 W:$Y!($E(IOST)="C") @IOF
117 S PG=PG+1 W !,?21,"Feeder Key List For Feeder System ",EC,?70,"Page: ",PG
118 I EC="PHA" W !,?22,"(NEW Feeder Key from NDF Match)",!!,?2,"Feeder Key",?24,"Description",?66,"Price Per",!,?66,"Dispense Unit",!,LN,! Q
119 I $D(ECECS)&(EC="ECS") W !?21,$S(ECECS="O":"(OLD Feeder Key sorted by Category-Procedure)",1:"(NEW Feeder Key sorted by Procedure-CPT Code)")
120 I $D(ECLAB)&(EC="LAB") W !?15,$S(ECLAB="O":"(OLD Feeder Key sorted by Local Feeder Key values)",1:" (NEW Feeder Key sorted by LMIP Codes)")
121 W !!,?5,"Feeder Key",?27,"Description",!,LN,!
122 Q
123ADD0(ECXFKEY) ;** Append zeros to decimal place on feeder key
124 ;
125 ;** Variable Definitions
126 ;** ECXFKEY - Value of Feeder Key
127 ;** Returns feeder key with zeros appended to make a
128 ;** four place decimal.
129 ;
130 N ECXD,LPCNT,LPEND,ECXFEKEY,ECXDEC
131 S ECXDEC=$P(ECXFKEY,".",2)
132 S LPEND=4-$L(ECXDEC)
133 F LPCNT=1:1:LPEND S ECXDEC=ECXDEC_"0"
134 S ECXFEKEY=$P(ECXFKEY,".",1)_"."_ECXDEC
135 Q ECXFEKEY
136 ;
Note: See TracBrowser for help on using the repository browser.