PSNCOMP ;BIR/WRT-match local name with NDF finds matches ; 12/18/98 13:31
;;4.0; NATIONAL DRUG FILE;**3,47**; 30 Oct 98
;
;Reference to ^PSDRUG supported by DBIA #2352,#221
;
START F PSNB=NBR:0 S PSNB=$O(^PSDRUG(PSNB)) Q:'PSNB D BLDIT I $D(PSNFL) Q:PSNFL=1
S:+PSNB<1 PSNB=99999999 S:PSNB'=$P(^PSNTRAN("END"),"^",1) $P(^PSNTRAN("END"),"^",1)=$S($D(^PSNTRAN(PSNB,0)):PSNB,1:PSNB-1) S IFN=$S($D(^PSNTRAN(PSNB,0)):PSNB,1:PSNB-1),^PSNTRAN(IFN,"END")=IFN I '$D(^PSNTRAN(IFN,0)) S ^PSNTRAN(IFN,0)=0
DONE K PSNB D KILL^PSNHIT Q
Q
BLDIT ; START ATTEMPT TO MATCH
Q:'$D(^PSDRUG(PSNB,0)) Q:$P(^PSDRUG(PSNB,0),"^",1)']""
I $D(^PSDRUG(PSNB,"ND")),$P(^PSDRUG(PSNB,"ND"),"^",2)]"" Q
I $D(PSNFLB),$D(^PSNTRAN(PSNB,0)) Q
D KILL^PSNHIT,^PSNDEA Q:$D(PSNINACT) Q:'$D(PSNDEA) K PSNDEA
NAM D:$D(XRTL) T0^%ZOSV ; START
S TT=0,TTT=0 S (PSNLOC,PSNNAM)=$P(^PSDRUG(PSNB,0),"^",1) W !!,"Match local drug ",PSNNAM W:$P(^PSDRUG(PSNB,0),"^",9)=1 ?64,"N/F",?70," with "
W !,?40,"ORDER UNIT: "
I $D(^PSDRUG(PSNB,660)) S PSNODE=^PSDRUG(PSNB,660) I $P(PSNODE,"^",2) S PSNOU=$P(PSNODE,"^",2) I $D(^DIC(51.5)),$D(^DIC(51.5,PSNOU)) W ?52,$S('$D(PSNOU):"",1:$P(^DIC(51.5,PSNOU,0),"^",1))
W !,?24,"DISPENSE UNITS/ORDER UNITS: ",$S('$D(PSNODE):"",1:$P(PSNODE,"^",5)),!,?37,"DISPENSE UNIT: ",$S('$D(PSNODE):"",1:$P(PSNODE,"^",8)) S NOM31=0,DUNCE=0
D NDC31 S NO31=0 Q:$D(DIRUT) W:NOM31=1 !,"No match on that NDC....",! I $D(Y(0)),Y(0)="YES" Q
GOSYN ; Match by Synonym NDC
S NOMSYN=0 D SYN^PSNNDC Q:$D(DIRUT) W:NOMSYN=1 !,"No match by Synonym NDC... now first word",! I $D(Y(0)),Y(0)="YES" S NOMSYM=0 Q
TRY1 W !,?5 S X=$P(PSNNAM," ",1),DIC="^PSNDF(50.6,",DIC(0)="Q" D ^DIC K DIC S:Y>0 PSNDA=+Y G:Y>0 ^PSNHIT I Y<0 W !!,"Match on first word failed...",! G TRY3
Q
Q
NDC31 ; Match by NDC field 31
I '$D(^PSDRUG(PSNB,2)) W !,"No NDC to match...",! S NO31=1 Q
I $D(^PSDRUG(PSNB,2)) S CODE=$P($G(^PSDRUG(PSNB,2)),"^",4) W:CODE']"" !,"No NDC to match...",! I CODE]"" W !,"I will try to match NDC: ",CODE," to NDF." S TT=1,ANS=CODE,NOM31=0 D STRT0^PSNNDC
Q
SETIT S PSNNAME=PSNNAM F X=",","/"," ","-" S PSNNAM=PSNNAME,PSNNAME="" F MJL=1:1 Q:MJL>$L(PSNNAM,X) S PSNNAME=PSNNAME_$S($P(PSNNAM,X,MJL)]"":$P(PSNNAM,X,MJL)_$S(MJL<$L(PSNNAM,X):" ",1:""),1:"")
I $P(PSNNAM," ")'?1A.E S PSNSP=$F(PSNNAM," "),PSNNAM=$E(PSNNAM,PSNSP,$L(PSNNAM))
Q
TRY2 S X="" F MJL=2:1 Q:MJL>$L(PSNNAM," ") I $L($P(PSNNAM," ",MJL))>$L(X) S X=$P(PSNNAM," ",MJL)
S DIC="^PSNDF(50.6,",DIC(0)="Q" D ^DIC K DIC G:Y>0 ^PSNHIT
TRY3 W !!,"No match . . . attempting to match by Trade Name" I $D(PSNTRFL) G:PSNTRFL UPNDC
S X=$O(^PSDRUG(PSNB,1,0)) I 'X S PSNTRFL=1 W !,"There are no Trade Names...unable to match",! G UPNDC
I '$O(^PSDRUG(PSNB,1,X)) S (PSNNAM,X)=$P(^PSDRUG(PSNB,1,X,0),"^"),PSNTRFL=1 G TRD
TRADE K ANS W !!,"Trade Names in YOUR local file for this drug are: "
S PSNFL=0,END=$P(^PSDRUG(PSNB,1,0),"^",3),WR="Enter choice or press RETURN to continue: ",FL=0
F JJ=0:0 S JJ=$O(^PSDRUG(PSNB,1,JJ)) Q:'JJ I $D(^PSDRUG(PSNB,1,JJ,0)),$P(^PSDRUG(PSNB,1,JJ,0),"^",3)=0 S FL=1 W !,JJ," ",$P(^PSDRUG(PSNB,1,JJ,0),"^",1) I JJ#10=0,END'=10 W !!,WR R ANS:DTIME S:'$T ANS="^" S:ANS["^" PSNFL=1 Q:PSNFL Q:ANS]""
I FL=0 S PSNTRFL=1 W !,"There are no Trade Names...unable to match",! G UPNDC
I $D(ANS),ANS?.E1C.E G TRADE
I $D(ANS),ANS["?" D TRD1^PSNHELP G TRADE
Q:PSNFL I $D(ANS),ANS']"" K ANS
TRPIC I '$D(ANS) R !!?10,"Enter your choice: ",ANS:DTIME S:'$T ANS="^"
I ANS?.E1C.E K ANS G TRPIC
S:ANS["^" PSNFL=1 Q:PSNFL G:ANS']"" UPNDC I ANS["?" D TR2^PSNHELP G TRPIC
I '$D(^PSDRUG(PSNB,1,ANS)) W !,"Invalid choice, try again!!" G TRADE
S (X,PSNNAM)=$P(^PSDRUG(PSNB,1,ANS,0),"^",1),PSNTRFL=1
TRD S DIC="^PSNDF(50.67,",DIC(0)="Q",D="T" D IX^DIC K DIC S:Y>0 ZZXX=$P(^PSNDF(50.67,+Y,0),"^",6) S:Y>0 PSNDA=$P(^PSNDF(50.68,ZZXX,0),"^",2) G:Y>0 ^PSNHIT
W !!,"Unable to match Trade Name",! ; G PUNT
UPNDC W !,"Do you want to attempt to match by NDC or UPN:" S DIR(0)="S^N:NDC;U:UPN;",DIR("B")="NDC" D ^DIR Q:$D(DIRUT) S PSNINQ=Y(0) G:PSNINQ="UPN" UCODE
TRY4 K ANS R !!,"Please enter NDC Code <WITH DASHES>: ",ANS:DTIME S:'$T ANS="^" G:ANS']"" PUNT I ANS="^" S PSNFL=1 Q
I ANS?.E1C.E K ANS G TRY4
I ANS["?" D NDC1^PSNHELP G TRY4
I ANS'?.N1"-".N1"-".N W !!,"Format should be MANUFACTURER'S CODE""-""PRODUCT CODE""-""PACKAGE CODE",!,"(i.e. 9999-999-99)" G TRY4
NDC F VV=1:1:3 S VV1=$S(VV=1:6,VV=2:4,VV=3:2) D NDCSET
S ANS=$P(ANS,"-",1)_$P(ANS,"-",2)_$P(ANS,"-",3) K VV,VV1
I '$D(^PSNDF(50.67,"NDC",ANS)) K ANS G PUNT
S PSNIEN=$O(^PSNDF(50.67,"NDC",ANS,0)),PSNFNM=$P(^PSNDF(50.67,PSNIEN,0),"^",6),PSNSIZE=$P(^PSNDF(50.67,PSNIEN,0),"^",8),PSNTYPE=$P(^PSNDF(50.67,PSNIEN,0),"^",9)
I $D(^PSNDF(50.68,PSNFNM,7)) S PSNPD=$P(^PSNDF(50.68,PSNFNM,7),"^",3) I PSNPD]"",(PSNPD<DT) W !,"NDC Code ("_ANS_") has been inactivated!!" G TRY4
S PSNNDF=$P(^PSNDF(50.68,PSNFNM,0),"^",2),PSNFORM=$P(^PSNDF(50.68,PSNFNM,0),"^"),PSNCLASS=$P(^PSNDF(50.68,PSNFNM,3),"^")
; D ING^PSNHELP I ANS["^" S PSNFL=1 Q
S PSNVAR="PUNT^PSNCOMP" D ASK^PSNSTCK D:"Yy"[ANS SET^PSNHIT Q
PUNT ;Match by VA Generic
W !!,"Unable to match by Name, Trade Name or NDC Code/UPN ",!
K LIST,^TMP($J) S DIC="^PSNDF(50.6,",DIC(0)="QEAM",DIC("W")="W $S($P(^PSNDF(50.6,+Y,0),U,2):"" **INACTIVE**"",1:"""")" D ^DIC K DIC S:Y>0 PSNDA=+Y
I Y>0,$P($G(^PSNDF(50.6,+Y,0)),"^",2) W !,"This entry has been inactivated!!" G PUNT
G:Y>0 ^PSNHIT G:X']"" OOPS^PSNHIT I X["^" S PSNFL=1 Q
NDCSET I $L($P(ANS,"-",VV))<VV1 S $P(ANS,"-",VV)=$E("0000000",1,VV1-$L($P(ANS,"-",VV)))_$P(ANS,"-",VV)
Q
UCODE K PSNUP R !!,"Enter UPN: ",PSNUP:DTIME S:'$T PSNUP="^" G:PSNUP']"" PUNT I PSNUP="^" S PSNFL=1 Q
I PSNUP?.E1C.E.E K PSNUP G UCODE
I PSNUP["?" W !,"Enter a UPN to attempt to match to NDF",! G UCODE
I '$D(^PSNDF(50.67,"UPN",PSNUP)) K PSNUP G PUNT
S PSNIEN=$O(^PSNDF(50.67,PSNUP,0)),PSNFNM=$P(^PSNDF(50.67,PSNIEN,0),"^",6),PSNSIZE=$P(^PSNDF(50.67,PSNIEN,0),"^",8),PSNTYPE=$P(^PSNDF(50.67,PSNIEN,0),"^",9)
I $D(^PSNDF(50.68,PSNFNM,7)) S PSNPD=$P(^PSNDF(50.68,PSNFNM,7),"^",3) I PSNPD]"",PSNPD<DT Q
S PSNNDF=$P(^PSNDF(50.68,PSNFNM,0),"^",2),PSNFORM=$P(^PSNDF(50.68,PSNFNM,0),"^"),PSNCLASS=$P(^PSNDF(50.68,PSNFNM,3),"^")
S PSNVAR="PUNT^PSNCOMP" D ASK^PSNSTCK D:"Yy"[ANS SET^PSNHIT Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSNCOMP 6255 printed Dec 13, 2024@02:23:50 Page 2
PSNCOMP ;BIR/WRT-match local name with NDF finds matches ; 12/18/98 13:31
+1 ;;4.0; NATIONAL DRUG FILE;**3,47**; 30 Oct 98
+2 ;
+3 ;Reference to ^PSDRUG supported by DBIA #2352,#221
+4 ;
START FOR PSNB=NBR:0
SET PSNB=$ORDER(^PSDRUG(PSNB))
if 'PSNB
QUIT
DO BLDIT
IF $DATA(PSNFL)
if PSNFL=1
QUIT
+1 if +PSNB<1
SET PSNB=99999999
if PSNB'=$PIECE(^PSNTRAN("END"),"^",1)
SET $PIECE(^PSNTRAN("END"),"^",1)=$SELECT($DATA(^PSNTRAN(PSNB,0)):PSNB,1:PSNB-1)
SET IFN=$SELECT($DATA(^PSNTRAN(PSNB,0)):PSNB,1:PSNB-1)
SET ^PSNTRAN(IFN,"END")=IFN
IF '$DATA(^PSNTRAN(IFN,0))
SET ^PSNTRAN(IFN,0)=0
DONE KILL PSNB
DO KILL^PSNHIT
QUIT
+1 QUIT
BLDIT ; START ATTEMPT TO MATCH
+1 if '$DATA(^PSDRUG(PSNB,0))
QUIT
if $PIECE(^PSDRUG(PSNB,0),"^",1)']""
QUIT
+2 IF $DATA(^PSDRUG(PSNB,"ND"))
IF $PIECE(^PSDRUG(PSNB,"ND"),"^",2)]""
QUIT
+3 IF $DATA(PSNFLB)
IF $DATA(^PSNTRAN(PSNB,0))
QUIT
+4 DO KILL^PSNHIT
DO ^PSNDEA
if $DATA(PSNINACT)
QUIT
if '$DATA(PSNDEA)
QUIT
KILL PSNDEA
NAM ; START
if $DATA(XRTL)
DO T0^%ZOSV
+1 SET TT=0
SET TTT=0
SET (PSNLOC,PSNNAM)=$PIECE(^PSDRUG(PSNB,0),"^",1)
WRITE !!,"Match local drug ",PSNNAM
if $PIECE(^PSDRUG(PSNB,0),"^",9)=1
WRITE ?64,"N/F",?70," with "
+2 WRITE !,?40,"ORDER UNIT: "
+3 IF $DATA(^PSDRUG(PSNB,660))
SET PSNODE=^PSDRUG(PSNB,660)
IF $PIECE(PSNODE,"^",2)
SET PSNOU=$PIECE(PSNODE,"^",2)
IF $DATA(^DIC(51.5))
IF $DATA(^DIC(51.5,PSNOU))
WRITE ?52,$SELECT('$DATA(PSNOU):"",1:$PIECE(^DIC(51.5,PSNOU,0),"^",1))
+4 WRITE !,?24,"DISPENSE UNITS/ORDER UNITS: ",$SELECT('$DATA(PSNODE):"",1:$PIECE(PSNODE,"^",5)),!,?37,"DISPENSE UNIT: ",$SELECT('$DATA(PSNODE):"",1:$PIECE(PSNODE,"^",8))
SET NOM31=0
SET DUNCE=0
+5 DO NDC31
SET NO31=0
if $DATA(DIRUT)
QUIT
if NOM31=1
WRITE !,"No match on that NDC....",!
IF $DATA(Y(0))
IF Y(0)="YES"
QUIT
GOSYN ; Match by Synonym NDC
+1 SET NOMSYN=0
DO SYN^PSNNDC
if $DATA(DIRUT)
QUIT
if NOMSYN=1
WRITE !,"No match by Synonym NDC... now first word",!
IF $DATA(Y(0))
IF Y(0)="YES"
SET NOMSYM=0
QUIT
TRY1 WRITE !,?5
SET X=$PIECE(PSNNAM," ",1)
SET DIC="^PSNDF(50.6,"
SET DIC(0)="Q"
DO ^DIC
KILL DIC
if Y>0
SET PSNDA=+Y
if Y>0
GOTO ^PSNHIT
IF Y<0
WRITE !!,"Match on first word failed...",!
GOTO TRY3
+1 QUIT
+2 QUIT
NDC31 ; Match by NDC field 31
+1 IF '$DATA(^PSDRUG(PSNB,2))
WRITE !,"No NDC to match...",!
SET NO31=1
QUIT
+2 IF $DATA(^PSDRUG(PSNB,2))
SET CODE=$PIECE($GET(^PSDRUG(PSNB,2)),"^",4)
if CODE']""
WRITE !,"No NDC to match...",!
IF CODE]""
WRITE !,"I will try to match NDC: ",CODE," to NDF."
SET TT=1
SET ANS=CODE
SET NOM31=0
DO STRT0^PSNNDC
+3 QUIT
SETIT SET PSNNAME=PSNNAM
FOR X=",","/"," ","-"
SET PSNNAM=PSNNAME
SET PSNNAME=""
FOR MJL=1:1
if MJL>$LENGTH(PSNNAM,X)
QUIT
SET PSNNAME=PSNNAME_$SELECT($PIECE(PSNNAM,X,MJL)]"":$PIECE(PSNNAM,X,MJL)_$SELECT(MJL<$LENGTH(PSNNAM,X):" ",1:""),1:"")
+1 IF $PIECE(PSNNAM," ")'?1A.E
SET PSNSP=$FIND(PSNNAM," ")
SET PSNNAM=$EXTRACT(PSNNAM,PSNSP,$LENGTH(PSNNAM))
+2 QUIT
TRY2 SET X=""
FOR MJL=2:1
if MJL>$LENGTH(PSNNAM," ")
QUIT
IF $LENGTH($PIECE(PSNNAM," ",MJL))>$LENGTH(X)
SET X=$PIECE(PSNNAM," ",MJL)
+1 SET DIC="^PSNDF(50.6,"
SET DIC(0)="Q"
DO ^DIC
KILL DIC
if Y>0
GOTO ^PSNHIT
TRY3 WRITE !!,"No match . . . attempting to match by Trade Name"
IF $DATA(PSNTRFL)
if PSNTRFL
GOTO UPNDC
+1 SET X=$ORDER(^PSDRUG(PSNB,1,0))
IF 'X
SET PSNTRFL=1
WRITE !,"There are no Trade Names...unable to match",!
GOTO UPNDC
+2 IF '$ORDER(^PSDRUG(PSNB,1,X))
SET (PSNNAM,X)=$PIECE(^PSDRUG(PSNB,1,X,0),"^")
SET PSNTRFL=1
GOTO TRD
TRADE KILL ANS
WRITE !!,"Trade Names in YOUR local file for this drug are: "
+1 SET PSNFL=0
SET END=$PIECE(^PSDRUG(PSNB,1,0),"^",3)
SET WR="Enter choice or press RETURN to continue: "
SET FL=0
+2 FOR JJ=0:0
SET JJ=$ORDER(^PSDRUG(PSNB,1,JJ))
if 'JJ
QUIT
IF $DATA(^PSDRUG(PSNB,1,JJ,0))
IF $PIECE(^PSDRUG(PSNB,1,JJ,0),"^",3)=0
SET FL=1
WRITE !,JJ," ",$PIECE(^PSDRUG(PSNB,1,JJ,0),"^",1)
IF JJ#10=0
IF END'=10
WRITE !!,WR
READ ANS:DTIME
if '$TEST
SET ANS="^"
if ANS["^"
SET PSNFL=1
if PSNFL
QUIT
if ANS]""
QUIT
+3 IF FL=0
SET PSNTRFL=1
WRITE !,"There are no Trade Names...unable to match",!
GOTO UPNDC
+4 IF $DATA(ANS)
IF ANS?.E1C.E
GOTO TRADE
+5 IF $DATA(ANS)
IF ANS["?"
DO TRD1^PSNHELP
GOTO TRADE
+6 if PSNFL
QUIT
IF $DATA(ANS)
IF ANS']""
KILL ANS
TRPIC IF '$DATA(ANS)
READ !!?10,"Enter your choice: ",ANS:DTIME
if '$TEST
SET ANS="^"
+1 IF ANS?.E1C.E
KILL ANS
GOTO TRPIC
+2 if ANS["^"
SET PSNFL=1
if PSNFL
QUIT
if ANS']""
GOTO UPNDC
IF ANS["?"
DO TR2^PSNHELP
GOTO TRPIC
+3 IF '$DATA(^PSDRUG(PSNB,1,ANS))
WRITE !,"Invalid choice, try again!!"
GOTO TRADE
+4 SET (X,PSNNAM)=$PIECE(^PSDRUG(PSNB,1,ANS,0),"^",1)
SET PSNTRFL=1
TRD SET DIC="^PSNDF(50.67,"
SET DIC(0)="Q"
SET D="T"
DO IX^DIC
KILL DIC
if Y>0
SET ZZXX=$PIECE(^PSNDF(50.67,+Y,0),"^",6)
if Y>0
SET PSNDA=$PIECE(^PSNDF(50.68,ZZXX,0),"^",2)
if Y>0
GOTO ^PSNHIT
+1 ; G PUNT
WRITE !!,"Unable to match Trade Name",!
UPNDC WRITE !,"Do you want to attempt to match by NDC or UPN:"
SET DIR(0)="S^N:NDC;U:UPN;"
SET DIR("B")="NDC"
DO ^DIR
if $DATA(DIRUT)
QUIT
SET PSNINQ=Y(0)
if PSNINQ="UPN"
GOTO UCODE
TRY4 KILL ANS
READ !!,"Please enter NDC Code <WITH DASHES>: ",ANS:DTIME
if '$TEST
SET ANS="^"
if ANS']""
GOTO PUNT
IF ANS="^"
SET PSNFL=1
QUIT
+1 IF ANS?.E1C.E
KILL ANS
GOTO TRY4
+2 IF ANS["?"
DO NDC1^PSNHELP
GOTO TRY4
+3 IF ANS'?.N1"-".N1"-".N
WRITE !!,"Format should be MANUFACTURER'S CODE""-""PRODUCT CODE""-""PACKAGE CODE",!,"(i.e. 9999-999-99)"
GOTO TRY4
NDC FOR VV=1:1:3
SET VV1=$SELECT(VV=1:6,VV=2:4,VV=3:2)
DO NDCSET
+1 SET ANS=$PIECE(ANS,"-",1)_$PIECE(ANS,"-",2)_$PIECE(ANS,"-",3)
KILL VV,VV1
+2 IF '$DATA(^PSNDF(50.67,"NDC",ANS))
KILL ANS
GOTO PUNT
+3 SET PSNIEN=$ORDER(^PSNDF(50.67,"NDC",ANS,0))
SET PSNFNM=$PIECE(^PSNDF(50.67,PSNIEN,0),"^",6)
SET PSNSIZE=$PIECE(^PSNDF(50.67,PSNIEN,0),"^",8)
SET PSNTYPE=$PIECE(^PSNDF(50.67,PSNIEN,0),"^",9)
+4 IF $DATA(^PSNDF(50.68,PSNFNM,7))
SET PSNPD=$PIECE(^PSNDF(50.68,PSNFNM,7),"^",3)
IF PSNPD]""
IF (PSNPD<DT)
WRITE !,"NDC Code ("_ANS_") has been inactivated!!"
GOTO TRY4
+5 SET PSNNDF=$PIECE(^PSNDF(50.68,PSNFNM,0),"^",2)
SET PSNFORM=$PIECE(^PSNDF(50.68,PSNFNM,0),"^")
SET PSNCLASS=$PIECE(^PSNDF(50.68,PSNFNM,3),"^")
+6 ; D ING^PSNHELP I ANS["^" S PSNFL=1 Q
+7 SET PSNVAR="PUNT^PSNCOMP"
DO ASK^PSNSTCK
if "Yy"[ANS
DO SET^PSNHIT
QUIT
PUNT ;Match by VA Generic
+1 WRITE !!,"Unable to match by Name, Trade Name or NDC Code/UPN ",!
+2 KILL LIST,^TMP($JOB)
SET DIC="^PSNDF(50.6,"
SET DIC(0)="QEAM"
SET DIC("W")="W $S($P(^PSNDF(50.6,+Y,0),U,2):"" **INACTIVE**"",1:"""")"
DO ^DIC
KILL DIC
if Y>0
SET PSNDA=+Y
+3 IF Y>0
IF $PIECE($GET(^PSNDF(50.6,+Y,0)),"^",2)
WRITE !,"This entry has been inactivated!!"
GOTO PUNT
+4 if Y>0
GOTO ^PSNHIT
if X']""
GOTO OOPS^PSNHIT
IF X["^"
SET PSNFL=1
QUIT
NDCSET IF $LENGTH($PIECE(ANS,"-",VV))<VV1
SET $PIECE(ANS,"-",VV)=$EXTRACT("0000000",1,VV1-$LENGTH($PIECE(ANS,"-",VV)))_$PIECE(ANS,"-",VV)
+1 QUIT
UCODE KILL PSNUP
READ !!,"Enter UPN: ",PSNUP:DTIME
if '$TEST
SET PSNUP="^"
if PSNUP']""
GOTO PUNT
IF PSNUP="^"
SET PSNFL=1
QUIT
+1 IF PSNUP?.E1C.E.E
KILL PSNUP
GOTO UCODE
+2 IF PSNUP["?"
WRITE !,"Enter a UPN to attempt to match to NDF",!
GOTO UCODE
+3 IF '$DATA(^PSNDF(50.67,"UPN",PSNUP))
KILL PSNUP
GOTO PUNT
+4 SET PSNIEN=$ORDER(^PSNDF(50.67,PSNUP,0))
SET PSNFNM=$PIECE(^PSNDF(50.67,PSNIEN,0),"^",6)
SET PSNSIZE=$PIECE(^PSNDF(50.67,PSNIEN,0),"^",8)
SET PSNTYPE=$PIECE(^PSNDF(50.67,PSNIEN,0),"^",9)
+5 IF $DATA(^PSNDF(50.68,PSNFNM,7))
SET PSNPD=$PIECE(^PSNDF(50.68,PSNFNM,7),"^",3)
IF PSNPD]""
IF PSNPD<DT
QUIT
+6 SET PSNNDF=$PIECE(^PSNDF(50.68,PSNFNM,0),"^",2)
SET PSNFORM=$PIECE(^PSNDF(50.68,PSNFNM,0),"^")
SET PSNCLASS=$PIECE(^PSNDF(50.68,PSNFNM,3),"^")
+7 SET PSNVAR="PUNT^PSNCOMP"
DO ASK^PSNSTCK
if "Yy"[ANS
DO SET^PSNHIT
QUIT
