- PSNVFY ;BIR/CCH&WRT-verifies matches allows rematch ; 02/08/00 8:45
- ;;4.0;NATIONAL DRUG FILE;**3,22,65,492,396**; 30 Oct 98;Build 190
- ;
- ;Reference to ^DIC(51.5 supported by DBIA #1931
- ;Reference to ^PSDRUG supported by DBIA #2352,#221
- ;
- S PSNFL=0,PSNW=0 F PSNB=0:0 S PSNB=$O(^PSNTRAN(PSNB)) Q:'PSNB D CHK I $D(PSNFL) Q:PSNFL
- DONE W:PSNW=0 !!,?13,"No Data has been generated" K PSNB,PSNFL D KILL Q
- CHK 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),"^")
- START W @IOF W ?2,"LOCAL DRUG NAME: ",PSNOLD S PSNW=1 W:$P(^PSDRUG(PSNB,0),"^",9)=1 ?68,"N/F"
- W !,?40,"ORDER UNIT:"
- I $D(^PSDRUG(PSNB,660)) S NODE=^PSDRUG(PSNB,660) I $P(NODE,"^",2) S PSNWRT=$P(NODE,"^",2) I $D(^DIC(51.5)),$D(^DIC(51.5,PSNWRT)) W ?52,$S('$D(PSNWRT):"",1:$P(^DIC(51.5,PSNWRT,0),"^",1))
- W !,?24,"DISPENSE UNITS/ORDER UNITS: ",$S('$D(NODE):"",1:$P(NODE,"^",5)),!,?37,"DISPENSE UNIT: ",$S('$D(NODE):"",1:$P(NODE,"^",8))
- W !!,"VA PRODUCT NAME: ",PSNNEW
- S D0=$P(^PSNTRAN(PSNB,0),"^",1),PSNFNM=$P(^PSNTRAN(PSNB,0),"^",2)
- S DA=D0,K=PSNFNM,X=$$PROD2^PSNAPIS(DA,K) I X]"",$P(X,"^")]"" W !,"VA PRINT NAME: ",$P(X,"^"),?57,"CMOP ID: ",$P(X,"^",2),!,"VA DISPENSE UNIT: ",$P(X,"^",4)
- W ?57,"MARKABLE FOR CMOP: " W:$P(X,"^",3)=1 "YES" W:$P(X,"^",3)=0 "NO" W:$P(X,"^",3)="" "NOT MARKED"
- S PSNSIZE=$P(^PSNTRAN(PSNB,0),"^",5),PSNTYPE=$P(^PSNTRAN(PSNB,0),"^",7)
- D PKSIZE^PSNOUT,PKTYPE^PSNOUT W !,?5,"PACKAGE SIZE: ",PSNSZE,!,?5,"PACKAGE TYPE: ",PSNTPE
- S PSNVADC=$P(^PSNTRAN(PSNB,0),"^",3) W !,"VA CLASS: ",$P(^PS(50.605,PSNVADC,0),"^",1)_" "_$P(^PS(50.605,PSNVADC,0),"^",2)
- W !,"CS FEDERAL SCHEDULE: "_$S($P($G(^PSNDF(50.68,PSNFNM,7)),"^"):$P(^PSNDF(50.68,PSNFNM,7),"^"),1:"")
- W !,"INGREDIENTS:" D INGRED^PSNOUT
- S NFI=$P($G(^PSNDF(50.68,PSNFNM,5)),"^"),NFR=$P($G(^PSNDF(50.68,PSNFNM,6,1,0)),"^")
- W !,"NATIONAL FORMULARY INDICATOR: " W:NFI=1 ?30,"YES" W:NFI=0 ?30,"NO"
- N PSNFD S PSNFD=$$GET1^DIQ(50.68,PSNFNM,109)
- W:PSNFD'="" !,"Formulary Designator: ",PSNFD ;PPSN
- W !,"NATIONAL FORMULARY RESTRICTION:",!,NFR
- I $D(^PSNDF(50.68,PSNFNM,5.1,1,0)) D FDT^PSNACT(PSNFNM) ;ppsn - formulary designator text
- N CPDATE,X,PSNCP D NOW^%DTC S CPDATE=X S PSNCP=$$CPTIER^PSNAPIS(PSNFNM,CPDATE,"",1) K CPDATE,X
- ; PSNCP = Copay Tier^Effective Date^End Date
- W !,"Copay Tier: ",$P(PSNCP,"^",1)
- W !,"Copay Effective Date: " S Y=$P(PSNCP,"^",2) D DD^%DT W Y K Y
- K D0,Y,PSNSIZE,PSNTYPE,PSNTPE,PSNSZE,PSNCON,STOPIT
- RESP W !!,"< Enter ""Y"" for yes, ""N"" for no >"
- W:'$D(Z9) !,"< Press RETURN to Pass to Next Drug >"
- R !!!,?10,"Is this a match ? ",ANS:DTIME I '$T S ANS="^" S PSNFL=1 Q
- I ANS?.E1C.E G RESP
- I ANS="" K ANS Q
- W ! I ANS["^" S PSNFL=1 Q
- I "Nn"[$E(ANS) K ANS D BLDIT^PSNCOMP Q:$P(^PSNTRAN(PSNB,0),"^",2)']"" G CHK
- I ANS["?" D RES2^PSNHELP K ANS G START
- I "YyNn"'[$E(ANS) W !," Invalid Response " G RESP
- S $P(^PSNTRAN(PSNB,0),"^",9)="Y",$P(^PSNTRAN(PSNB,0),"^",10)=DUZ D:$G(PSEDIT)'=1 SET^PSNMRG ;PSEDIT set in ^PSNOUT
- Q
- KILL K ANS,PSNSIZE,PSNSZ,PSNTYP,PSNTYPE,PSNDA,PSNSTDA,PSNDDA,PSNUNDA,PSNCLASS,PSNDF,PSNFNM,PSNFORM,PSNNDF,DIC,PSNFL,NBR,PSNNEW,PSNOLD,PSNPST,X,Y,PSNCON,STOPIT
- K PSNFN,PSNNAM,PSNNAME,PSNNL,PSNVAR,PSND,PSNDFM,PSNVC,PSNVCL,RM,SL,ZZ,ZZZ,PSNTPE,PSNSZE,VV,VVV,JJ,MJL,KK,IN,PSNODE,PSNOU,NODE,PSNWRT,PSNVADC,PSNENT,PSNF,PSNM,PSNLOC,^TMP($J,"PSNND"),ASC,PSNRAN,PSNV,PSNWR,PSNX,PSNZ,WRT,BB,END,PSNP,PSNW
- K CODE,DA,DATE,DIR,EEE,FFF,FL,GGG,IEN,J,K,NO31,NOM31,NOMSYN,DUNCE,PP,PSNARY,PSNIEN,PSNP,PTPS,QQ,RR,ST,TT,TTT,WR,XX,XXX,Y,ZXZX,DDD,LIST,PPQ,PSNTRFL,PSNXZ,STOP,PSNPD,PSNUP,PSNINQ,NFI
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSNVFY 3760 printed Feb 18, 2025@23:51:28 Page 2
- PSNVFY ;BIR/CCH&WRT-verifies matches allows rematch ; 02/08/00 8:45
- +1 ;;4.0;NATIONAL DRUG FILE;**3,22,65,492,396**; 30 Oct 98;Build 190
- +2 ;
- +3 ;Reference to ^DIC(51.5 supported by DBIA #1931
- +4 ;Reference to ^PSDRUG supported by DBIA #2352,#221
- +5 ;
- +6 SET PSNFL=0
- SET PSNW=0
- FOR PSNB=0:0
- SET PSNB=$ORDER(^PSNTRAN(PSNB))
- if 'PSNB
- QUIT
- DO CHK
- IF $DATA(PSNFL)
- if PSNFL
- QUIT
- DONE if PSNW=0
- WRITE !!,?13,"No Data has been generated"
- KILL PSNB,PSNFL
- DO KILL
- QUIT
- CHK IF $DATA(PSNFL)
- if PSNFL
- QUIT
- +1 SET PSNP=$GET(^PSDRUG(PSNB,"I"))
- IF PSNP
- IF PSNP<DT
- KILL ^PSNTRAN(PSNB,0)
- QUIT
- +2 if '$DATA(^PSNTRAN(PSNB,0))
- QUIT
- if $PIECE(^PSNTRAN(PSNB,0),"^",9)="Y"
- QUIT
- if '$PIECE(^PSNTRAN(PSNB,0),"^",2)
- QUIT
- +3 SET PSNPST=^PSNTRAN(PSNB,0)
- SET PSNOLD=$PIECE(^PSDRUG(PSNB,0),U)
- SET PSNNEW=$PIECE(^PSNDF(50.68,$PIECE(PSNPST,"^",2),0),"^")
- START WRITE @IOF
- WRITE ?2,"LOCAL DRUG NAME: ",PSNOLD
- SET PSNW=1
- if $PIECE(^PSDRUG(PSNB,0),"^",9)=1
- WRITE ?68,"N/F"
- +1 WRITE !,?40,"ORDER UNIT:"
- +2 IF $DATA(^PSDRUG(PSNB,660))
- SET NODE=^PSDRUG(PSNB,660)
- IF $PIECE(NODE,"^",2)
- SET PSNWRT=$PIECE(NODE,"^",2)
- IF $DATA(^DIC(51.5))
- IF $DATA(^DIC(51.5,PSNWRT))
- WRITE ?52,$SELECT('$DATA(PSNWRT):"",1:$PIECE(^DIC(51.5,PSNWRT,0),"^",1))
- +3 WRITE !,?24,"DISPENSE UNITS/ORDER UNITS: ",$SELECT('$DATA(NODE):"",1:$PIECE(NODE,"^",5)),!,?37,"DISPENSE UNIT: ",$SELECT('$DATA(NODE):"",1:$PIECE(NODE,"^",8))
- +4 WRITE !!,"VA PRODUCT NAME: ",PSNNEW
- +5 SET D0=$PIECE(^PSNTRAN(PSNB,0),"^",1)
- SET PSNFNM=$PIECE(^PSNTRAN(PSNB,0),"^",2)
- +6 SET DA=D0
- SET K=PSNFNM
- SET X=$$PROD2^PSNAPIS(DA,K)
- IF X]""
- IF $PIECE(X,"^")]""
- WRITE !,"VA PRINT NAME: ",$PIECE(X,"^"),?57,"CMOP ID: ",$PIECE(X,"^",2),!,"VA DISPENSE UNIT: ",$PIECE(X,"^",4)
- +7 WRITE ?57,"MARKABLE FOR CMOP: "
- if $PIECE(X,"^",3)=1
- WRITE "YES"
- if $PIECE(X,"^",3)=0
- WRITE "NO"
- if $PIECE(X,"^",3)=""
- WRITE "NOT MARKED"
- +8 SET PSNSIZE=$PIECE(^PSNTRAN(PSNB,0),"^",5)
- SET PSNTYPE=$PIECE(^PSNTRAN(PSNB,0),"^",7)
- +9 DO PKSIZE^PSNOUT
- DO PKTYPE^PSNOUT
- WRITE !,?5,"PACKAGE SIZE: ",PSNSZE,!,?5,"PACKAGE TYPE: ",PSNTPE
- +10 SET PSNVADC=$PIECE(^PSNTRAN(PSNB,0),"^",3)
- WRITE !,"VA CLASS: ",$PIECE(^PS(50.605,PSNVADC,0),"^",1)_" "_$PIECE(^PS(50.605,PSNVADC,0),"^",2)
- +11 WRITE !,"CS FEDERAL SCHEDULE: "_$SELECT($PIECE($GET(^PSNDF(50.68,PSNFNM,7)),"^"):$PIECE(^PSNDF(50.68,PSNFNM,7),"^"),1:"")
- +12 WRITE !,"INGREDIENTS:"
- DO INGRED^PSNOUT
- +13 SET NFI=$PIECE($GET(^PSNDF(50.68,PSNFNM,5)),"^")
- SET NFR=$PIECE($GET(^PSNDF(50.68,PSNFNM,6,1,0)),"^")
- +14 WRITE !,"NATIONAL FORMULARY INDICATOR: "
- if NFI=1
- WRITE ?30,"YES"
- if NFI=0
- WRITE ?30,"NO"
- +15 NEW PSNFD
- SET PSNFD=$$GET1^DIQ(50.68,PSNFNM,109)
- +16 ;PPSN
- if PSNFD'=""
- WRITE !,"Formulary Designator: ",PSNFD
- +17 WRITE !,"NATIONAL FORMULARY RESTRICTION:",!,NFR
- +18 ;ppsn - formulary designator text
- IF $DATA(^PSNDF(50.68,PSNFNM,5.1,1,0))
- DO FDT^PSNACT(PSNFNM)
- +19 NEW CPDATE,X,PSNCP
- DO NOW^%DTC
- SET CPDATE=X
- SET PSNCP=$$CPTIER^PSNAPIS(PSNFNM,CPDATE,"",1)
- KILL CPDATE,X
- +20 ; PSNCP = Copay Tier^Effective Date^End Date
- +21 WRITE !,"Copay Tier: ",$PIECE(PSNCP,"^",1)
- +22 WRITE !,"Copay Effective Date: "
- SET Y=$PIECE(PSNCP,"^",2)
- DO DD^%DT
- WRITE Y
- KILL Y
- +23 KILL D0,Y,PSNSIZE,PSNTYPE,PSNTPE,PSNSZE,PSNCON,STOPIT
- RESP WRITE !!,"< Enter ""Y"" for yes, ""N"" for no >"
- +1 if '$DATA(Z9)
- WRITE !,"< Press RETURN to Pass to Next Drug >"
- +2 READ !!!,?10,"Is this a match ? ",ANS:DTIME
- IF '$TEST
- SET ANS="^"
- SET PSNFL=1
- QUIT
- +3 IF ANS?.E1C.E
- GOTO RESP
- +4 IF ANS=""
- KILL ANS
- QUIT
- +5 WRITE !
- IF ANS["^"
- SET PSNFL=1
- QUIT
- +6 IF "Nn"[$EXTRACT(ANS)
- KILL ANS
- DO BLDIT^PSNCOMP
- if $PIECE(^PSNTRAN(PSNB,0),"^",2)']""
- QUIT
- GOTO CHK
- +7 IF ANS["?"
- DO RES2^PSNHELP
- KILL ANS
- GOTO START
- +8 IF "YyNn"'[$EXTRACT(ANS)
- WRITE !," Invalid Response "
- GOTO RESP
- +9 ;PSEDIT set in ^PSNOUT
- SET $PIECE(^PSNTRAN(PSNB,0),"^",9)="Y"
- SET $PIECE(^PSNTRAN(PSNB,0),"^",10)=DUZ
- if $GET(PSEDIT)'=1
- DO SET^PSNMRG
- +10 QUIT
- KILL KILL ANS,PSNSIZE,PSNSZ,PSNTYP,PSNTYPE,PSNDA,PSNSTDA,PSNDDA,PSNUNDA,PSNCLASS,PSNDF,PSNFNM,PSNFORM,PSNNDF,DIC,PSNFL,NBR,PSNNEW,PSNOLD,PSNPST,X,Y,PSNCON,STOPIT
- +1 KILL PSNFN,PSNNAM,PSNNAME,PSNNL,PSNVAR,PSND,PSNDFM,PSNVC,PSNVCL,RM,SL,ZZ,ZZZ,PSNTPE,PSNSZE,VV,VVV,JJ,MJL,KK,IN,PSNODE,PSNOU,NODE,PSNWRT,PSNVADC,PSNENT,PSNF,PSNM,PSNLOC,^TMP($JOB,"PSNND"),ASC,PSNRAN,PSNV,PSNWR,PSNX,PSNZ,WRT,BB,END,PSNP,PSNW
- +2 KILL CODE,DA,DATE,DIR,EEE,FFF,FL,GGG,IEN,J,K,NO31,NOM31,NOMSYN,DUNCE,PP,PSNARY,PSNIEN,PSNP,PTPS,QQ,RR,ST,TT,TTT,WR,XX,XXX,Y,ZXZX,DDD,LIST,PPQ,PSNTRFL,PSNXZ,STOP,PSNPD,PSNUP,PSNINQ,NFI