- PSNSTCL ;BIR/WRT-ALLOWS USER TO CLASSIFY A DRUG THAT CANNOT BE MATCHED ; 11/22/98 15:10
- ;;4.0; NATIONAL DRUG FILE;**3,55**; 30 Oct 98
- ;
- ;Reference to ^PS(50.3 supported by DBIA #2612
- ;Reference to ^PSDRUG supported by DBIA #2352,#221
- ;Reference to ^PS(59.7 supported by DBIA #2613
- ;
- 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"
- W !,"classed through ""the National Drug File merge procedure"" you cannot change it!",!
- START 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
- I ANS1?.E1C.E G START
- I "Yy"[$E(ANS1) G MLT
- I "?"[$E(ANS1) D VACLS^PSNHELP1 G START
- I "Nn"'[$E(ANS1)!(ANS1="") W !,"ANSWER MUST BE YES OR NO " G START
- S PSNFL=0 F PSNMM=1:1 D DRUG Q:PSNFL
- DONE K PSNMM,PDA,VADC,X,Y,IFN,PP,COD,FLAG,PRIM,PSNFL,DRUG,CL,PSNCLANS,ANS1,VV,NAM,DA,PSNCLDA Q
- DRUG W ! S DIC="^PSDRUG(",DIC(0)="QEAM" D ^DIC K DIC I "^"[X S PSNFL=1 Q
- I "?"[$E(X) D CL^PSNHELP1 G CLASS
- I Y<1 S PSNFL=1 Q
- S DRUG=+Y I $D(^PSDRUG(DRUG,"ND")),$P(^PSDRUG(DRUG,"ND"),"^",2)]"" W !,"SORRY, CLASSIFICATION CANNOT BE CHANGED",! Q
- CLASS 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),"^")_" // "
- R PSNCLANS:DTIME I '$T S PSNFL=1 Q
- I PSNCLANS?.E1C.E G CLASS
- I PSNCLANS']"",'$D(CL) S PSNFL=1,PSNCLANS="^"
- I PSNCLANS']"",$D(CL),$D(^PS(50.605,CL,0)) S PSNCLANS=$P(^PS(50.605,CL,0),"^",1)
- I "^"[$E(PSNCLANS) S PSNFL=1 Q
- I PSNCLANS="?" D CL^PSNHELP1 G CLASS
- 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
- I "XXINPHAS"'[$E(PSNCLANS,1,2),PSNCLANS?2A.3"0" W !,"THIS IS NOT A VALID ANSWER, YOU MUST BE MORE SPECIFIC",! G CLASS
- I PSNCLANS'?2A.3N W !,"THIS IS AN INCORRECT FORMAT ",! G CLASS
- I PSNCLANS?2A.3N&('$D(^PS(50.605,"B",PSNCLANS))) W !," THIS CLASSIFICATION DOES NOT EXIST. PLEASE TRY AGAIN. ",! G CLASS
- 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)
- 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
- 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
- I FLAG=0 S PRIM=$P($G(^PSDRUG(DRUG,2)),"^",6) I PRIM,$D(^PS(50.3,PRIM)) S ^PSDRUG("APC",PRIM,PSNCLANS,DRUG)=""
- I $D(^PSNTRAN(DRUG,0)),$P(^PSNTRAN(DRUG,0),"^",2)']"" K ^PSNTRAN(DRUG,0)
- ;
- 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)
- S PRIM=$P($G(^PSDRUG(DRUG,2)),"^") S:PRIM ^PSDRUG("AOC",PRIM,$P(^PS(50.605,PSNCLDA,0),"^",1),DRUG)=""
- Q
- MLT 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))
- I $D(^PSNTRAN),$D(IFN),$D(^PSNTRAN(IFN,"END")),$P(^PSNTRAN(IFN,"END"),"^",3)']"" K ^PSNTRAN(IFN,"END")
- F VV=0:0 S NAM=$O(^PSDRUG("B",NAM)) Q:NAM="" S DA=$O(^PSDRUG("B",NAM,0)) D LOOP Q:PSNFL
- S:$D(PDA) $P(^PSNTRAN(PDA,"END"),"^",3)=$P(^PSNTRAN("END"),"^",3) G DONE
- LOOP I $D(^PSDRUG(DA,"I")),$P(^PSDRUG(DA,"I"),"^")<DT Q
- I '$D(^PSDRUG(DA,"ND")) D SET Q
- I $D(^PSDRUG(DA,"ND")),$P(^PSDRUG(DA,"ND"),"^",2)']"" D SET Q
- Q
- SET S DRUG=DA W !!,NAM D CLASS Q:PSNFL S $P(^PSNTRAN("END"),"^",3)=NAM,PDA=DA K:$D(IFN) ^PSNTRAN(IFN,"END") Q
- PSNSTCL ;BIR/WRT-ALLOWS USER TO CLASSIFY A DRUG THAT CANNOT BE MATCHED ; 11/22/98 15:10
- +1 ;;4.0; NATIONAL DRUG FILE;**3,55**; 30 Oct 98
- +2 ;
- +3 ;Reference to ^PS(50.3 supported by DBIA #2612
- +4 ;Reference to ^PSDRUG supported by DBIA #2352,#221
- +5 ;Reference to ^PS(59.7 supported by DBIA #2613
- +6 ;
- +7 WRITE !!,"This option allows a VA Drug Classification to be entered for",!,"a drug in your local drug file, however, if the drug has been"
- +8 WRITE !,"classed through ""the National Drug File merge procedure"" you cannot change it!",!
- START READ !,"Do you wish to automatically loop through all unmatched drugs?",!,"<Reply Y,N or ""^"" to quit> : "
- READ ANS1:DTIME
- IF '$TEST
- SET ANS1="^"
- IF ANS1["^"!(ANS1']"")
- GOTO DONE
- +1 IF ANS1?.E1C.E
- GOTO START
- +2 IF "Yy"[$EXTRACT(ANS1)
- GOTO MLT
- +3 IF "?"[$EXTRACT(ANS1)
- DO VACLS^PSNHELP1
- GOTO START
- +4 IF "Nn"'[$EXTRACT(ANS1)!(ANS1="")
- WRITE !,"ANSWER MUST BE YES OR NO "
- GOTO START
- +5 SET PSNFL=0
- FOR PSNMM=1:1
- DO DRUG
- IF PSNFL
- QUIT
- DONE KILL PSNMM,PDA,VADC,X,Y,IFN,PP,COD,FLAG,PRIM,PSNFL,DRUG,CL,PSNCLANS,ANS1,VV,NAM,DA,PSNCLDA
- QUIT
- DRUG WRITE !
- SET DIC="^PSDRUG("
- SET DIC(0)="QEAM"
- DO ^DIC
- KILL DIC
- IF "^"[X
- SET PSNFL=1
- QUIT
- +1 IF "?"[$EXTRACT(X)
- DO CL^PSNHELP1
- GOTO CLASS
- +2 IF Y<1
- SET PSNFL=1
- QUIT
- +3 SET DRUG=+Y
- IF $DATA(^PSDRUG(DRUG,"ND"))
- IF $PIECE(^PSDRUG(DRUG,"ND"),"^",2)]""
- WRITE !,"SORRY, CLASSIFICATION CANNOT BE CHANGED",!
- QUIT
- CLASS WRITE !!," Select VA DRUG CLASS CODE: "
- KILL CL,PSNCLANS
- IF $DATA(^PSDRUG(DRUG,"ND"))
- SET CL=$PIECE(^PSDRUG(DRUG,"ND"),"^",6)
- IF $DATA(^PS(50.605,CL,0))
- WRITE $PIECE(^PS(50.605,CL,0),"^")_" // "
- +1 READ PSNCLANS:DTIME
- IF '$TEST
- SET PSNFL=1
- QUIT
- +2 IF PSNCLANS?.E1C.E
- GOTO CLASS
- +3 IF PSNCLANS']""
- IF '$DATA(CL)
- SET PSNFL=1
- SET PSNCLANS="^"
- +4 IF PSNCLANS']""
- IF $DATA(CL)
- IF $DATA(^PS(50.605,CL,0))
- SET PSNCLANS=$PIECE(^PS(50.605,CL,0),"^",1)
- +5 IF "^"[$EXTRACT(PSNCLANS)
- SET PSNFL=1
- QUIT
- +6 IF PSNCLANS="?"
- DO CL^PSNHELP1
- GOTO CLASS
- +7 IF PSNCLANS="??"
- SET DIC="^PS(50.605,"
- SET X="??"
- SET DIC(0)="QEM"
- DO ^DIC
- KILL DIC
- IF Y<0
- WRITE !!,$SELECT($DATA(DRUG):$PIECE(^PSDRUG(DRUG,0),"^",1),$DATA(NAM):NAM,1:"")
- GOTO CLASS
- +8 IF "XXINPHAS"'[$EXTRACT(PSNCLANS,1,2)
- IF PSNCLANS?2A.3"0"
- WRITE !,"THIS IS NOT A VALID ANSWER, YOU MUST BE MORE SPECIFIC",!
- GOTO CLASS
- +9 IF PSNCLANS'?2A.3N
- WRITE !,"THIS IS AN INCORRECT FORMAT ",!
- GOTO CLASS
- +10 IF PSNCLANS?2A.3N&('$DATA(^PS(50.605,"B",PSNCLANS)))
- WRITE !," THIS CLASSIFICATION DOES NOT EXIST. PLEASE TRY AGAIN. ",!
- GOTO CLASS
- +11 IF $DATA(^PSDRUG("VAC"))
- FOR VADC=0:0
- SET VADC=$ORDER(^PSDRUG("VAC",VADC))
- IF 'VADC
- QUIT
- IF $DATA(^PSDRUG("VAC",VADC,DRUG))
- KILL ^PSDRUG("VAC",VADC,DRUG)
- +12 SET PSNCLDA=$ORDER(^PS(50.605,"B",PSNCLANS,0))
- SET $PIECE(^PSDRUG(DRUG,"ND"),"^",6)=PSNCLDA
- SET ^PSDRUG("VAC",PSNCLDA,DRUG)=""
- SET FLAG=0
- IF $DATA(^PS(59.7,1,49.99))
- IF +^(49.99)
- SET $PIECE(^PSDRUG(DRUG,0),"^",2)=PSNCLANS
- +13 IF $DATA(^PSDRUG("APC"))
- FOR PP=0:0
- SET PP=$ORDER(^PSDRUG("APC",PP))
- IF 'PP
- QUIT
- SET COD=""
- FOR
- SET COD=$ORDER(^PSDRUG("APC",PP,COD))
- IF COD=""
- QUIT
- IF $DATA(^PSDRUG("APC",PP,COD,DRUG))
- KILL ^PSDRUG("APC",PP,COD,DRUG)
- SET ^PSDRUG("APC",PP,PSNCLANS,DRUG)=""
- SET FLAG=1
- +14 IF FLAG=0
- SET PRIM=$PIECE($GET(^PSDRUG(DRUG,2)),"^",6)
- IF PRIM
- IF $DATA(^PS(50.3,PRIM))
- SET ^PSDRUG("APC",PRIM,PSNCLANS,DRUG)=""
- +15 IF $DATA(^PSNTRAN(DRUG,0))
- IF $PIECE(^PSNTRAN(DRUG,0),"^",2)']""
- KILL ^PSNTRAN(DRUG,0)
- +16 ;
- +17 IF $DATA(^PSDRUG("AOC"))
- SET PP=0
- FOR
- SET PP=$ORDER(^PSDRUG("AOC",PP))
- IF 'PP
- QUIT
- SET COD=""
- FOR
- SET COD=$ORDER(^PSDRUG("AOC",PP,COD))
- IF COD=""
- QUIT
- IF $DATA(^PSDRUG("AOC",PP,COD,DRUG))
- KILL ^PSDRUG("AOC",PP,COD,DRUG)
- +18 SET PRIM=$PIECE($GET(^PSDRUG(DRUG,2)),"^")
- IF PRIM
- SET ^PSDRUG("AOC",PRIM,$PIECE(^PS(50.605,PSNCLDA,0),"^",1),DRUG)=""
- +19 QUIT
- MLT SET PSNFL=0
- SET NAM=$SELECT($DATA(^PSNTRAN("END")):$PIECE(^PSNTRAN("END"),"^",3),1:"")
- IF NAM]""
- SET IFN=$ORDER(^PSDRUG("B",NAM,0))
- SET NAM=$SELECT($LENGTH(NAM)=1:NAM,1:$EXTRACT(NAM,1,$LENGTH(NAM)-1))
- +1 IF $DATA(^PSNTRAN)
- IF $DATA(IFN)
- IF $DATA(^PSNTRAN(IFN,"END"))
- IF $PIECE(^PSNTRAN(IFN,"END"),"^",3)']""
- KILL ^PSNTRAN(IFN,"END")
- +2 FOR VV=0:0
- SET NAM=$ORDER(^PSDRUG("B",NAM))
- IF NAM=""
- QUIT
- SET DA=$ORDER(^PSDRUG("B",NAM,0))
- DO LOOP
- IF PSNFL
- QUIT
- +3 IF $DATA(PDA)
- SET $PIECE(^PSNTRAN(PDA,"END"),"^",3)=$PIECE(^PSNTRAN("END"),"^",3)
- GOTO DONE
- LOOP IF $DATA(^PSDRUG(DA,"I"))
- IF $PIECE(^PSDRUG(DA,"I"),"^")<DT
- QUIT
- +1 IF '$DATA(^PSDRUG(DA,"ND"))
- DO SET
- QUIT
- +2 IF $DATA(^PSDRUG(DA,"ND"))
- IF $PIECE(^PSDRUG(DA,"ND"),"^",2)']""
- DO SET
- QUIT
- +3 QUIT
- SET SET DRUG=DA
- WRITE !!,NAM
- DO CLASS
- IF PSNFL
- QUIT
- SET $PIECE(^PSNTRAN("END"),"^",3)=NAM
- SET PDA=DA
- IF $DATA(IFN)
- KILL ^PSNTRAN(IFN,"END")
- QUIT
