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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSNSTCL 3864 printed Apr 09, 2024@21:26:13 Page 2
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
