PSNPPSNW ;HP/MJE-PPSN update NDF data additional update code ; 05 Mar 2014 1:20 PM
;;4.0;NATIONAL DRUG FILE;**513,563,569**; 30 Oct 98;Build 3
;
;Reference to ^PSSREF supported by DBIA #6371
;Reference to ^PSDRUG supported by DBIA #221
;Reference to ^PSSUTIL supported by DBIA #3107
;Reference to ^PS(59.7 supported by DBIA #2613
;
REMATCH(DA,PSNFNM) ;called by PSNPPSNU
;DA & DISPDRG are both local drug IEN
;PSNFNM is IEN of NDF (50.68) entry to match to
N DISPDRG S DISPDRG=""
;
S DISPDRG=DA
;-vvvvvvvvv- from PSSDEE -vvvvvvvvv-
;
N FLGNDF,K,NEWDF,NFI,NFR,NWND,NWPC1,NWPC3,OLDDF,PSNCLASS,PSNFL,PSNLOC,PSNNDF,PSNNEW,PSNOLD,PSNP,PSNPST,PSNSIZE
N PSNTYPE,PSNVADC,PSNW,VAID,REC
ASKND ;
D RSET,EN1(PSNFNM,DA)
D REACT S DA=DISPDRG I $D(^PSDRUG(DA,"ND")),$P(^PSDRUG(DA,"ND"),"^",2)]"" D
.S PSNP=$G(^PSDRUG(DA,"I")) I PSNP,PSNP<DT Q
.S NWND=^PSDRUG(DA,"ND"),NWPC1=$P(NWND,"^",1),NWPC3=$P(NWND,"^",3),DA=NWPC1,K=NWPC3 S X=$$PSJDF^PSNAPIS(DA,K) S NEWDF=$P(X,"^",2),DA=DISPDRG
.; changed PSSUTIL call 2nd argument to use 0 instead of 1 ('quiet' mode)
.D EN2^PSSUTIL(DISPDRG,0) S:'$D(OLDDF) OLDDF="" I OLDDF'=NEWDF S FLGNDF=1
.N X,Y,Z D
..S X=$P($G(^PSDRUG(DISPDRG,0)),"^") Q:X=""
..S Y=$G(^PSNDF(50.68,PSNFNM,1)),Z=$P(Y,"^",2),Y=$P(Y,"^")
..S ^TMP($J,"REMATCHED",X)=Y_"^"_Z_"^"_DISPDRG_"^"_PSNFNM
Q
;
;-vvvvvvvvv- from PSSDEE1 -vvvvvvvvv-
;
RSET ;
S:$D(^PSDRUG(DA,"ND")) PSNID=$P(^PSDRUG(DA,"ND"),"^",10)
S PSNP=$G(^PSDRUG(DA,"I")) I PSNP,PSNP<DT Q:$D(^PSDRUG(DA,"I"))
S DA=DISPDRG D UNMDRUG^PSSUTIL(DA) S:$D(^PSDRUG(DA,3)) $P(^PSDRUG(DA,3),"^",1)=0 K:$D(^PSDRUG("AQ",DA)) ^PSDRUG("AQ",DA)
I $D(PSNID),PSNID]"" K PSNID
D ^PSSREF ; *OK
Q
;
;-vvvvvvvvv- from PSSUTIL -vvvvvvvvv-
;
EN1(PSNDIEN,PSN50IEN) ;Receive Drug entries that have been unmatched
N PSSLD,PSSPWXEX,X,DIC,DA
I PSNPS="N" S DIC="^NDFK(5000.2,",DIC(0)="LMXZ",X="",X=PSNDIEN K DD,DO D FILE^DICN D ERROR^PSNPPSNU:$D(ERROR("DIERR"))
Q:PSN50IEN=""
K ^PSDRUG(PSN50IEN,"DOS"),^PSDRUG(PSN50IEN,"DOS1")
K ^PSDRUG(PSN50IEN,"DOS2")
Q
;
;-vvvvvvvvv- from PSNOUT -vvvvvvvvv-
;
REACT ; code for reactivation of inactive drug in local drug file
I $O(^PSNDF(50.6,0)) S XX=$S('$D(^PSDRUG(DA,"ND")):1,1:$P(^("ND"),"^",2)="") I XX D
.;BLDIT^PSNCOMP is the heart of the matching, GONE is okay
.S (PSNB,PSNDRG,Z9)=DA,PSNLOC=$P(^PSDRUG(PSNB,0),"^",1) K ^PSNTRAN(PSNB) D GONE^PSNDRUG,BLDIT
.;CHK is below (needs cleaning - DONE), SET^PSNMRG & GONE are okay
.S DA=Z9 D CHK(DA),SET^PSNMRG,GONE^PSNDRUG K Z9,XX
Q
;
;-vvvvvvvvv- from PSNCOMP -vvvvvvvvv-
;
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
S XX=PSNFNM D KILL^PSNHIT S PSNFNM=XX K XX
;***** next line: DEA check: implemented silent
D Q:$D(PSNINACT) Q:'$D(PSNDEA) K PSNDEA
.K PSNINACT I $D(^PSDRUG(PSNB,"I")),$P(^PSDRUG(PSNB,"I"),"^",1)]"" S:+^PSDRUG(PSNB,"I")<DT PSNINACT=1
.S PSNDEA=$P(^PSDRUG(PSNB,0),"^",3)
.F VV=0,"I","M" I PSNDEA[VV S ^PSNTRAN(PSNB,0)="0^^^^^^^"_DUZ K VV,PSNDEA Q
.K VV Q
S PSNSIZE=$O(^PS(50.609,"B","OTHER",0)),PSNTYPE=$O(^PS(50.608,"B","OTHER",0))
S PSNNDF=$P(^PSNDF(50.68,PSNFNM,0),"^",2),PSNCLASS=$P(^PSNDF(50.68,PSNFNM,3),"^") ; GEN NM, CLASS
D SET
Q
;-vvvvvvvvv- from PSNHIT -vvvvvvvvv- sets the match in ^PSNTRAN to be verified
;
SET S:'$D(^PSNTRAN(PSNB,0)) $P(^PSNTRAN(0),"^",4)=($P(^PSNTRAN(0),"^",4))+1,$P(^PSNTRAN(0),"^",3)=PSNB
S ^PSNTRAN(PSNB,0)=PSNNDF_"^"_PSNFNM_"^"_PSNCLASS_"^^"_PSNSIZE_"^^"_PSNTYPE_"^"_DUZ ;D PKI W:$D(IOF) @IOF
S:'$D(PSNFL) PSNFL=0
Q
;
;
;-vvvvvvvvv- from PSNVFY -vvvvvvvvv-
;
CHK(PSNB) ;
I $D(PSNFL) Q:PSNFL
S PSNP=$G(^PSDRUG(PSNB,"I")) I PSNP,PSNP<DT K ^PSNTRAN(PSNB,0) Q
Q:'$D(^PSNTRAN(PSNB,0)) Q:$P(^PSNTRAN(PSNB,0),"^",9)="Y" Q:'$P(^PSNTRAN(PSNB,0),"^",2)
S PSNPST=^PSNTRAN(PSNB,0),PSNOLD=$P(^PSDRUG(PSNB,0),U),PSNNEW=$P(^PSNDF(50.68,$P(PSNPST,"^",2),0),"^")
; condensed from START^PSNVFY
S PSNW=1
S PSNVADC=$P(^PSNTRAN(PSNB,0),"^",3)
S NFI=$P($G(^PSNDF(50.68,PSNFNM,5)),"^"),NFR=$P($G(^PSNDF(50.68,PSNFNM,6,1,0)),"^")
S $P(^PSNTRAN(PSNB,0),"^",9)="Y",$P(^PSNTRAN(PSNB,0),"^",10)=DUZ
Q
;
REPORT ;
;take data from ^TMP($J,"REMATCHED",GN_NM)= VA_PRT_NM ^ VA_PROD_ID
;and put it into ^TMP("PSN PPSN PARSED",$J,"MESSAGE3",...
N NM,VANM,PSNDISPD,PSNVPRD,PSNVPRDN
N X S X="PPS-N Update File: "_$P(PSNHLD,";",1) D ADDLINE(X) S X="" D ADDLINE(X) ;add blank line after file name
I '$D(^TMP($J,"REMATCHED")) D MSGHDR(1) Q
D MSGHDR(0)
N X S (VANM,NM)="" F S NM=$O(^TMP($J,"REMATCHED",NM)) Q:NM="" D
.S VANM=$G(^TMP($J,"REMATCHED",NM)),VAID=$P(VANM,"^",2),PSNDISPD=$P(VANM,"^",3),PSNVPRD=$P(VANM,"^",4),VANM=$P(VANM,"^")
.S PSNVPRDN=$$GET1^DIQ(50.68,PSNVPRD,.01)
.S X=" "_NM_" ("_PSNDISPD_")" D ADDLINE(X)
.S X=" RE-MATCHED TO" D ADDLINE(X)
.S X=" "_VANM_" ["_VAID_"]" D ADDLINE(X)
.S X=" "_PSNVPRDN_" ("_PSNVPRD_")" D ADDLINE(X)
.S X=" " D ADDLINE(X)
K ^TMP($J,"REMATCHED")
Q
;
MSGHDR(NONE) ;insert MESS3 header
N I,X
W !
F I=1:1 S X="HDRTXT+"_I,X=$T(@X) S X=$P(X,";",3) Q:X="" D
.I 'NONE,X["[No re-matches]" Q
.D ADDLINE(X)
Q
;
ADDLINE(X) ;
N C
S (C,^TMP("PSN PPSN PARSED",$J,"MESSAGE3",0))=$G(^TMP("PSN PPSN PARSED",$J,"MESSAGE3",0))+1
S ^TMP("PSN PPSN PARSED",$J,"MESSAGE3",C)=X
Q
;
HDRTXT ;
;;The following local drug entries have been re-matched to the National Drug File based on the recommendations of the PPSN management group.;
;;If you do not agree with any of these re-matches you may re-match them locally.;
;; ;
;; [No re-matches];
;;;
;
;=============================
;misc export stuff (unrelated)
;=============================
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSNPPSNW 5826 printed Dec 13, 2024@02:24:51 Page 2
PSNPPSNW ;HP/MJE-PPSN update NDF data additional update code ; 05 Mar 2014 1:20 PM
+1 ;;4.0;NATIONAL DRUG FILE;**513,563,569**; 30 Oct 98;Build 3
+2 ;
+3 ;Reference to ^PSSREF supported by DBIA #6371
+4 ;Reference to ^PSDRUG supported by DBIA #221
+5 ;Reference to ^PSSUTIL supported by DBIA #3107
+6 ;Reference to ^PS(59.7 supported by DBIA #2613
+7 ;
REMATCH(DA,PSNFNM) ;called by PSNPPSNU
+1 ;DA & DISPDRG are both local drug IEN
+2 ;PSNFNM is IEN of NDF (50.68) entry to match to
+3 NEW DISPDRG
SET DISPDRG=""
+4 ;
+5 SET DISPDRG=DA
+6 ;-vvvvvvvvv- from PSSDEE -vvvvvvvvv-
+7 ;
+8 NEW FLGNDF,K,NEWDF,NFI,NFR,NWND,NWPC1,NWPC3,OLDDF,PSNCLASS,PSNFL,PSNLOC,PSNNDF,PSNNEW,PSNOLD,PSNP,PSNPST,PSNSIZE
+9 NEW PSNTYPE,PSNVADC,PSNW,VAID,REC
ASKND ;
+1 DO RSET
DO EN1(PSNFNM,DA)
+2 DO REACT
SET DA=DISPDRG
IF $DATA(^PSDRUG(DA,"ND"))
IF $PIECE(^PSDRUG(DA,"ND"),"^",2)]""
Begin DoDot:1
+3 SET PSNP=$GET(^PSDRUG(DA,"I"))
IF PSNP
IF PSNP<DT
QUIT
+4 SET NWND=^PSDRUG(DA,"ND")
SET NWPC1=$PIECE(NWND,"^",1)
SET NWPC3=$PIECE(NWND,"^",3)
SET DA=NWPC1
SET K=NWPC3
SET X=$$PSJDF^PSNAPIS(DA,K)
SET NEWDF=$PIECE(X,"^",2)
SET DA=DISPDRG
+5 ; changed PSSUTIL call 2nd argument to use 0 instead of 1 ('quiet' mode)
+6 DO EN2^PSSUTIL(DISPDRG,0)
if '$DATA(OLDDF)
SET OLDDF=""
IF OLDDF'=NEWDF
SET FLGNDF=1
+7 NEW X,Y,Z
Begin DoDot:2
+8 SET X=$PIECE($GET(^PSDRUG(DISPDRG,0)),"^")
if X=""
QUIT
+9 SET Y=$GET(^PSNDF(50.68,PSNFNM,1))
SET Z=$PIECE(Y,"^",2)
SET Y=$PIECE(Y,"^")
+10 SET ^TMP($JOB,"REMATCHED",X)=Y_"^"_Z_"^"_DISPDRG_"^"_PSNFNM
End DoDot:2
End DoDot:1
+11 QUIT
+12 ;
+13 ;-vvvvvvvvv- from PSSDEE1 -vvvvvvvvv-
+14 ;
RSET ;
+1 if $DATA(^PSDRUG(DA,"ND"))
SET PSNID=$PIECE(^PSDRUG(DA,"ND"),"^",10)
+2 SET PSNP=$GET(^PSDRUG(DA,"I"))
IF PSNP
IF PSNP<DT
if $DATA(^PSDRUG(DA,"I"))
QUIT
+3 SET DA=DISPDRG
DO UNMDRUG^PSSUTIL(DA)
if $DATA(^PSDRUG(DA,3))
SET $PIECE(^PSDRUG(DA,3),"^",1)=0
if $DATA(^PSDRUG("AQ",DA))
KILL ^PSDRUG("AQ",DA)
+4 IF $DATA(PSNID)
IF PSNID]""
KILL PSNID
+5 ; *OK
DO ^PSSREF
+6 QUIT
+7 ;
+8 ;-vvvvvvvvv- from PSSUTIL -vvvvvvvvv-
+9 ;
EN1(PSNDIEN,PSN50IEN) ;Receive Drug entries that have been unmatched
+1 NEW PSSLD,PSSPWXEX,X,DIC,DA
+2 IF PSNPS="N"
SET DIC="^NDFK(5000.2,"
SET DIC(0)="LMXZ"
SET X=""
SET X=PSNDIEN
KILL DD,DO
DO FILE^DICN
if $DATA(ERROR("DIERR"))
DO ERROR^PSNPPSNU
+3 if PSN50IEN=""
QUIT
+4 KILL ^PSDRUG(PSN50IEN,"DOS"),^PSDRUG(PSN50IEN,"DOS1")
+5 KILL ^PSDRUG(PSN50IEN,"DOS2")
+6 QUIT
+7 ;
+8 ;-vvvvvvvvv- from PSNOUT -vvvvvvvvv-
+9 ;
REACT ; code for reactivation of inactive drug in local drug file
+1 IF $ORDER(^PSNDF(50.6,0))
SET XX=$SELECT('$DATA(^PSDRUG(DA,"ND")):1,1:$PIECE(^("ND"),"^",2)="")
IF XX
Begin DoDot:1
+2 ;BLDIT^PSNCOMP is the heart of the matching, GONE is okay
+3 SET (PSNB,PSNDRG,Z9)=DA
SET PSNLOC=$PIECE(^PSDRUG(PSNB,0),"^",1)
KILL ^PSNTRAN(PSNB)
DO GONE^PSNDRUG
DO BLDIT
+4 ;CHK is below (needs cleaning - DONE), SET^PSNMRG & GONE are okay
+5 SET DA=Z9
DO CHK(DA)
DO SET^PSNMRG
DO GONE^PSNDRUG
KILL Z9,XX
End DoDot:1
+6 QUIT
+7 ;
+8 ;-vvvvvvvvv- from PSNCOMP -vvvvvvvvv-
+9 ;
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 SET XX=PSNFNM
DO KILL^PSNHIT
SET PSNFNM=XX
KILL XX
+5 ;***** next line: DEA check: implemented silent
+6 Begin DoDot:1
+7 KILL PSNINACT
IF $DATA(^PSDRUG(PSNB,"I"))
IF $PIECE(^PSDRUG(PSNB,"I"),"^",1)]""
if +^PSDRUG(PSNB,"I")<DT
SET PSNINACT=1
+8 SET PSNDEA=$PIECE(^PSDRUG(PSNB,0),"^",3)
+9 FOR VV=0,"I","M"
IF PSNDEA[VV
SET ^PSNTRAN(PSNB,0)="0^^^^^^^"_DUZ
KILL VV,PSNDEA
QUIT
+10 KILL VV
QUIT
End DoDot:1
if $DATA(PSNINACT)
QUIT
if '$DATA(PSNDEA)
QUIT
KILL PSNDEA
+11 SET PSNSIZE=$ORDER(^PS(50.609,"B","OTHER",0))
SET PSNTYPE=$ORDER(^PS(50.608,"B","OTHER",0))
+12 ; GEN NM, CLASS
SET PSNNDF=$PIECE(^PSNDF(50.68,PSNFNM,0),"^",2)
SET PSNCLASS=$PIECE(^PSNDF(50.68,PSNFNM,3),"^")
+13 DO SET
+14 QUIT
+15 ;-vvvvvvvvv- from PSNHIT -vvvvvvvvv- sets the match in ^PSNTRAN to be verified
+16 ;
SET if '$DATA(^PSNTRAN(PSNB,0))
SET $PIECE(^PSNTRAN(0),"^",4)=($PIECE(^PSNTRAN(0),"^",4))+1
SET $PIECE(^PSNTRAN(0),"^",3)=PSNB
+1 ;D PKI W:$D(IOF) @IOF
SET ^PSNTRAN(PSNB,0)=PSNNDF_"^"_PSNFNM_"^"_PSNCLASS_"^^"_PSNSIZE_"^^"_PSNTYPE_"^"_DUZ
+2 if '$DATA(PSNFL)
SET PSNFL=0
+3 QUIT
+4 ;
+5 ;
+6 ;-vvvvvvvvv- from PSNVFY -vvvvvvvvv-
+7 ;
CHK(PSNB) ;
+1 IF $DATA(PSNFL)
if PSNFL
QUIT
+2 SET PSNP=$GET(^PSDRUG(PSNB,"I"))
IF PSNP
IF PSNP<DT
KILL ^PSNTRAN(PSNB,0)
QUIT
+3 if '$DATA(^PSNTRAN(PSNB,0))
QUIT
if $PIECE(^PSNTRAN(PSNB,0),"^",9)="Y"
QUIT
if '$PIECE(^PSNTRAN(PSNB,0),"^",2)
QUIT
+4 SET PSNPST=^PSNTRAN(PSNB,0)
SET PSNOLD=$PIECE(^PSDRUG(PSNB,0),U)
SET PSNNEW=$PIECE(^PSNDF(50.68,$PIECE(PSNPST,"^",2),0),"^")
+5 ; condensed from START^PSNVFY
+6 SET PSNW=1
+7 SET PSNVADC=$PIECE(^PSNTRAN(PSNB,0),"^",3)
+8 SET NFI=$PIECE($GET(^PSNDF(50.68,PSNFNM,5)),"^")
SET NFR=$PIECE($GET(^PSNDF(50.68,PSNFNM,6,1,0)),"^")
+9 SET $PIECE(^PSNTRAN(PSNB,0),"^",9)="Y"
SET $PIECE(^PSNTRAN(PSNB,0),"^",10)=DUZ
+10 QUIT
+11 ;
REPORT ;
+1 ;take data from ^TMP($J,"REMATCHED",GN_NM)= VA_PRT_NM ^ VA_PROD_ID
+2 ;and put it into ^TMP("PSN PPSN PARSED",$J,"MESSAGE3",...
+3 NEW NM,VANM,PSNDISPD,PSNVPRD,PSNVPRDN
+4 ;add blank line after file name
NEW X
SET X="PPS-N Update File: "_$PIECE(PSNHLD,";",1)
DO ADDLINE(X)
SET X=""
DO ADDLINE(X)
+5 IF '$DATA(^TMP($JOB,"REMATCHED"))
DO MSGHDR(1)
QUIT
+6 DO MSGHDR(0)
+7 NEW X
SET (VANM,NM)=""
FOR
SET NM=$ORDER(^TMP($JOB,"REMATCHED",NM))
if NM=""
QUIT
Begin DoDot:1
+8 SET VANM=$GET(^TMP($JOB,"REMATCHED",NM))
SET VAID=$PIECE(VANM,"^",2)
SET PSNDISPD=$PIECE(VANM,"^",3)
SET PSNVPRD=$PIECE(VANM,"^",4)
SET VANM=$PIECE(VANM,"^")
+9 SET PSNVPRDN=$$GET1^DIQ(50.68,PSNVPRD,.01)
+10 SET X=" "_NM_" ("_PSNDISPD_")"
DO ADDLINE(X)
+11 SET X=" RE-MATCHED TO"
DO ADDLINE(X)
+12 SET X=" "_VANM_" ["_VAID_"]"
DO ADDLINE(X)
+13 SET X=" "_PSNVPRDN_" ("_PSNVPRD_")"
DO ADDLINE(X)
+14 SET X=" "
DO ADDLINE(X)
End DoDot:1
+15 KILL ^TMP($JOB,"REMATCHED")
+16 QUIT
+17 ;
MSGHDR(NONE) ;insert MESS3 header
+1 NEW I,X
+2 WRITE !
+3 FOR I=1:1
SET X="HDRTXT+"_I
SET X=$TEXT(@X)
SET X=$PIECE(X,";",3)
if X=""
QUIT
Begin DoDot:1
+4 IF 'NONE
IF X["[No re-matches]"
QUIT
+5 DO ADDLINE(X)
End DoDot:1
+6 QUIT
+7 ;
ADDLINE(X) ;
+1 NEW C
+2 SET (C,^TMP("PSN PPSN PARSED",$JOB,"MESSAGE3",0))=$GET(^TMP("PSN PPSN PARSED",$JOB,"MESSAGE3",0))+1
+3 SET ^TMP("PSN PPSN PARSED",$JOB,"MESSAGE3",C)=X
+4 QUIT
+5 ;
HDRTXT ;
+1 ;;The following local drug entries have been re-matched to the National Drug File based on the recommendations of the PPSN management group.;
+2 ;;If you do not agree with any of these re-matches you may re-match them locally.;
+3 ;; ;
+4 ;; [No re-matches];
+5 ;;;
+6 ;
+7 ;=============================
+8 ;misc export stuff (unrelated)
+9 ;=============================
+10 QUIT
