source: WorldVistAEHR/trunk/r/NATIONAL_DRUG_FILE-PSN/PSNSTCL.m@ 724

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

initial load of WorldVistAEHR

File size: 3.7 KB
Line 
1PSNSTCL ;BIR/WRT-ALLOWS USER TO CLASSIFY A DRUG THAT CANNOT BE MATCHED ; 11/22/98 15:10
2 ;;4.0; NATIONAL DRUG FILE;**3,55**; 30 Oct 98
3 ;
4 ;Reference to ^PS(50.3 supported by DBIA #2612
5 ;Reference to ^PSDRUG supported by DBIA #2352,#221
6 ;Reference to ^PS(59.7 supported by DBIA #2613
7 ;
8 W !!,"This option allows a VA Drug Classification to be entered for",!,"a drug in your local drug file, however, if the drug has been"
9 W !,"classed through ""the National Drug File merge procedure"" you cannot change it!",!
10START R !,"Do you wish to automatically loop through all unmatched drugs?",!,"<Reply Y,N or ""^"" to quit> : " R ANS1:DTIME S:'$T ANS1="^" I ANS1["^"!(ANS1']"") G DONE
11 I ANS1?.E1C.E G START
12 I "Yy"[$E(ANS1) G MLT
13 I "?"[$E(ANS1) D VACLS^PSNHELP1 G START
14 I "Nn"'[$E(ANS1)!(ANS1="") W !,"ANSWER MUST BE YES OR NO " G START
15 S PSNFL=0 F PSNMM=1:1 D DRUG Q:PSNFL
16DONE K PSNMM,PDA,VADC,X,Y,IFN,PP,COD,FLAG,PRIM,PSNFL,DRUG,CL,PSNCLANS,ANS1,VV,NAM,DA,PSNCLDA Q
17DRUG W ! S DIC="^PSDRUG(",DIC(0)="QEAM" D ^DIC K DIC I "^"[X S PSNFL=1 Q
18 I "?"[$E(X) D CL^PSNHELP1 G CLASS
19 I Y<1 S PSNFL=1 Q
20 S DRUG=+Y I $D(^PSDRUG(DRUG,"ND")),$P(^PSDRUG(DRUG,"ND"),"^",2)]"" W !,"SORRY, CLASSIFICATION CANNOT BE CHANGED",! Q
21CLASS W !!," Select VA DRUG CLASS CODE: " K CL,PSNCLANS I $D(^PSDRUG(DRUG,"ND")) S CL=$P(^PSDRUG(DRUG,"ND"),"^",6) I $D(^PS(50.605,CL,0)) W $P(^PS(50.605,CL,0),"^")_" // "
22 R PSNCLANS:DTIME I '$T S PSNFL=1 Q
23 I PSNCLANS?.E1C.E G CLASS
24 I PSNCLANS']"",'$D(CL) S PSNFL=1,PSNCLANS="^"
25 I PSNCLANS']"",$D(CL),$D(^PS(50.605,CL,0)) S PSNCLANS=$P(^PS(50.605,CL,0),"^",1)
26 I "^"[$E(PSNCLANS) S PSNFL=1 Q
27 I PSNCLANS="?" D CL^PSNHELP1 G CLASS
28 I PSNCLANS="??" S DIC="^PS(50.605,",X="??",DIC(0)="QEM" D ^DIC K DIC I Y<0 W !!,$S($D(DRUG):$P(^PSDRUG(DRUG,0),"^",1),$D(NAM):NAM,1:"") G CLASS
29 I "XXINPHAS"'[$E(PSNCLANS,1,2),PSNCLANS?2A.3"0" W !,"THIS IS NOT A VALID ANSWER, YOU MUST BE MORE SPECIFIC",! G CLASS
30 I PSNCLANS'?2A.3N W !,"THIS IS AN INCORRECT FORMAT ",! G CLASS
31 I PSNCLANS?2A.3N&('$D(^PS(50.605,"B",PSNCLANS))) W !," THIS CLASSIFICATION DOES NOT EXIST. PLEASE TRY AGAIN. ",! G CLASS
32 I $D(^PSDRUG("VAC")) F VADC=0:0 S VADC=$O(^PSDRUG("VAC",VADC)) Q:'VADC I $D(^PSDRUG("VAC",VADC,DRUG)) K ^PSDRUG("VAC",VADC,DRUG)
33 S PSNCLDA=$O(^PS(50.605,"B",PSNCLANS,0)),$P(^PSDRUG(DRUG,"ND"),"^",6)=PSNCLDA,^PSDRUG("VAC",PSNCLDA,DRUG)="" S FLAG=0 I $D(^PS(59.7,1,49.99)),+^(49.99) S $P(^PSDRUG(DRUG,0),"^",2)=PSNCLANS
34 I $D(^PSDRUG("APC")) F PP=0:0 S PP=$O(^PSDRUG("APC",PP)) Q:'PP S COD="" F S COD=$O(^PSDRUG("APC",PP,COD)) Q:COD="" I $D(^PSDRUG("APC",PP,COD,DRUG)) K ^PSDRUG("APC",PP,COD,DRUG) S ^PSDRUG("APC",PP,PSNCLANS,DRUG)="" S FLAG=1
35 I FLAG=0 S PRIM=$P($G(^PSDRUG(DRUG,2)),"^",6) I PRIM,$D(^PS(50.3,PRIM)) S ^PSDRUG("APC",PRIM,PSNCLANS,DRUG)=""
36 I $D(^PSNTRAN(DRUG,0)),$P(^PSNTRAN(DRUG,0),"^",2)']"" K ^PSNTRAN(DRUG,0)
37 ;
38 I $D(^PSDRUG("AOC")) S PP=0 F S PP=$O(^PSDRUG("AOC",PP)) Q:'PP S COD="" F S COD=$O(^PSDRUG("AOC",PP,COD)) Q:COD="" I $D(^PSDRUG("AOC",PP,COD,DRUG)) K ^PSDRUG("AOC",PP,COD,DRUG)
39 S PRIM=$P($G(^PSDRUG(DRUG,2)),"^") S:PRIM ^PSDRUG("AOC",PRIM,$P(^PS(50.605,PSNCLDA,0),"^",1),DRUG)=""
40 Q
41MLT S PSNFL=0,NAM=$S($D(^PSNTRAN("END")):$P(^PSNTRAN("END"),"^",3),1:"") S:NAM]"" IFN=$O(^PSDRUG("B",NAM,0)),NAM=$S($L(NAM)=1:NAM,1:$E(NAM,1,$L(NAM)-1))
42 I $D(^PSNTRAN),$D(IFN),$D(^PSNTRAN(IFN,"END")),$P(^PSNTRAN(IFN,"END"),"^",3)']"" K ^PSNTRAN(IFN,"END")
43 F VV=0:0 S NAM=$O(^PSDRUG("B",NAM)) Q:NAM="" S DA=$O(^PSDRUG("B",NAM,0)) D LOOP Q:PSNFL
44 S:$D(PDA) $P(^PSNTRAN(PDA,"END"),"^",3)=$P(^PSNTRAN("END"),"^",3) G DONE
45LOOP I $D(^PSDRUG(DA,"I")),$P(^PSDRUG(DA,"I"),"^")<DT Q
46 I '$D(^PSDRUG(DA,"ND")) D SET Q
47 I $D(^PSDRUG(DA,"ND")),$P(^PSDRUG(DA,"ND"),"^",2)']"" D SET Q
48 Q
49SET S DRUG=DA W !!,NAM D CLASS Q:PSNFL S $P(^PSNTRAN("END"),"^",3)=NAM,PDA=DA K:$D(IFN) ^PSNTRAN(IFN,"END") Q
Note: See TracBrowser for help on using the repository browser.