- 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 Feb 18, 2025@23:49:59 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