- PSNACT ;BIR/DMA&WRT-inquiries by VAPN, CMOP ID, or NDC ;07/02/03 14:01
- ;;4.0;NATIONAL DRUG FILE;**22,35,47,62,65,70,160,169,262,296,429,492,396**; 30 Oct 98;Build 190
- ;
- ;Reference to ^PS(50.606 supported by DBIA #2174
- ;Reference to ^PSNAPIS supported by DBIA #2531
- ;
- I '$D(IORVON) S X="IORVON;IORVOFF" D ENDR^%ZISS
- K DIC,DIR F ZXX=0:0 W ! D TEXT,ASKIT Q:$D(DIRUT)
- K QUIT,DIR,DIC,OLDDA,PROMPT,J,I,IEN,PPP,Y,Y1,Y3,Y5,Y6,Y7,Z0,Z1,Z3,Z5,Z6,Z7,ZA,ZXX,ASK,NDX,SIE,PSN,PSN1,MORE,SIE1
- N PMIS,QQQ,ENG,MAP,D,ANS,ZCT,DYAYGO,DUOUT,DTOUT,PSNTIER
- Q
- TEXT W !,"This option allows you to lookup NDF file information three ways (VA Product",!,"Name, NDC, or CMOP ID number).",!
- Q
- ASKIT S DIR(0)="SA^VA:VA PRODUCT;N:NDC;C:CMOP ID",DIR("A")="LOOKUP BY (VA) PRODUCT, (N)DC, OR (C)MOP ID ? " D ^DIR G END:$D(DIRUT) S ASK=Y(0)
- I ASK="NDC" D NDC
- I ASK="VA PRODUCT" D LISTNDC
- I ASK="CMOP ID" D CMOP
- Q
- ;
- NDC ;OR UPN
- K PROMPT S DIR(0)="SA^N:NDC;U:UPN",DIR("A")="NDC (N) or UPN (U) ? " D ^DIR G END:$D(DIRUT) S PROMPT=Y(0)
- I PROMPT="NDC" S DIR(0)="F",DIR("A")="Enter NDC with or without Dashes (-)" D ^DIR G END:$D(DIRUT) D:X["-" PAD S DIC=50.67,DIC(0)="EQZN",D=PROMPT,DIC("W")="S PSNCTNDC=Y D GETTIERN^PSNACT(PSNCTNDC)" D IX^DIC Q:Y<0 S DA=+Y,NDF=Y(0) D LKNDC
- I PROMPT="UPN" S DIC=50.67,DIC(0)="AEQZN",DIC("A")="Select "_PROMPT_":"_" ",D=PROMPT,DIC("W")="S PSNCTNDC=Y D GETTIERN^PSNACT(PSNCTNDC)" D IX^DIC Q:Y<0 S DA=+Y,NDF=Y(0) D LKNDC
- Q
- LKNDC W @IOF,!,"NDC: ",$P(NDF,"^",2),$$DT($P(NDF,"^",7))," UPN: ",$P(NDF,"^",3),!,"VA Product Name: ",$P(^PSNDF(50.68,$P(NDF,"^",6),0),"^"),!,"Manufacturer: ",$P($G(^PS(55.95,+$P(NDF,"^",4),0)),"^")," Trade Name: ",$P(NDF,"^",5),!,"Route: "
- S K=0 F S K=$O(^PSNDF(50.67,DA,1,K)) Q:'K W $P(^(K,0),"^")," "
- W !,"Package Size: ",$P(^PS(50.609,$P(NDF,"^",8),0),"^")," Package Type: ",$P(^PS(50.608,$P(NDF,"^",9),0),"^")
- S ZA=$P(NDF,"^",6) D PRINT(ZA)
- Q
- END K DA,DA,DIC,DIE,DIR,DR,IN,ING,J,K,L,NEW,NDF,OLD,OLDDA,PROMPT,X,Y,Y1,Y3,Y7,^TMP($J) Q
- ;
- PRODI ;INQUIRE INTO 50.68
- F S DIC="^PSNDF(50.68,",DIC(0)="AEQM" D ^DIC Q:Y<0 S DA=+Y D EN^DIQ
- K DA,DIC,X,Y Q
- ;
- NDCI ;INQUIRE INTO 50.67
- S DIR(0)="SA^N:NDC;U:UPN;T:TRADE;P:PRODUCT",DIR("A")="NDC (N), UPN (U), Trade name (T), or Product (P) " D ^DIR G END:$D(DIRUT) S PROMPT=Y(0) G LISTNDC:PROMPT["PRO",LISTNDC1:PROMPT="NDC" I PROMPT["T" S PROMPT="T"
- F S DIC="^PSNDF(50.67,",DIC(0)="AEQZS",DIC("A")="Select "_PROMPT S:PROMPT="T" DIC("A")=DIC("A")_"rade name" S DIC("A")=DIC("A")_" ",D=PROMPT D IX^DIC Q:Y<0 S DA=+Y D EN^DIQ
- K DA,DIC,DIR,PROMPT,X,Y Q
- ;
- LINK ;LINK NDCS OR UPNS
- S DIR(0)="SA^N:NDC;U:UPN",DIR("A")="NDC (N) or UPN (U) ",DIR("B")="NDC" D ^DIR G END:$D(DIRUT) S PROMPT=Y(0)
- F Q:$D(DIRUT)!(Y<0) S DIC=50.67,DIC(0)="AEQZ",DIC("A")="Enter Current "_PROMPT_" ",D=PROMPT D IX^DIC Q:Y<0 S DA=+Y,OLD=$P(Y(0),"^",$S(PROMPT="NDC":2,1:3)) D
- .K DIR S DIR(0)="F^"_$S(PROMPT="NDC":"12:12",1:"1:40")_"^W:$D(^PSNDF(50.67,PROMPT,X)) !!,""That "_PROMPT_" already exists"",! K:$D(^PSNDF(50.67,PROMPT,X)) X",DIR("A")="Enter a new "_PROMPT_" " D ^DIR K DIR Q:$D(DIRUT) S NEW=Y
- .I PROMPT="NDC" D
- ..S IN=$O(^PSNDF(50.67,DA,2,"B",NEW,0)) I IN S DIR(0)="Y" W !,"Those NDCs are already linked" S DIR("A")="Do you want to unlink them " D ^DIR Q:$D(DIRUT) Q:'Y
- ..I IN S DA(1)=DA,DA=IN,DIE="^PSNDF(50.67,"_DA(1)_",2,",DR=".01///@;" D ^DIE W !,"Unlinked",! Q
- ..I 'IN S DIE="^PSNDF(50.67,",DR="1////"_NEW D ^DIE K DD,DO S DA(1)=DA,DIC="^PSNDF(50.67,"_DA(1)_",2,",DIC(0)="L",DLAYGO=50.67,DIC("P")=$P(^DD(50.67,11,0),"^",2),X=OLD D ^DIC W !,"Linked",! Q
- .I PROMPT="UPN" D
- ..S IN=$O(^PSNDF(50.67,DA,3,"B",NEW,0)) I IN S DIR(0)="Y" W !,"Those UPNs are already linked" S DIR("A")="Do you want to unlink them " D ^DIR Q:$D(DIRUT) Q:'Y
- ..S DA(1)=DA,DA=IN,DIE="^PSNDF(50.67,"_DA(1)_",3,",DR=".01///@;" D ^DIE W !,"Unlinked",! Q
- ..I 'IN S DIE="^PSNDF(50.67,",DR="1////"_NEW D ^DIE K DD,DO S DA(1)=DA,DIC="^PSNDF(50.67,"_DA(1)_",3,",DIC(0)="L",DLAYGO=50.67,DIC("P")=$P(^DD(50.67,12,0),"^",2),X=OLD D ^DIC W !,"Linked",! Q
- G LINK
- ;
- LISTNDC ;LOOK UP NDCS BY PRODUCT
- K L,DA,^TMP($J),DIC
- S DIC=50.68,DIC(0)="AQEMZ",DIC("W")="S PSNTDRUG=Y D GETTIER^PSNACT(PSNTDRUG)" D ^DIC G END:Y<0
- S IEN=+Y W @IOF D PRINT(IEN) Q:$G(QUIT) F SIE=0:0 S SIE=$O(^PSNDF(50.68,"ANDC",IEN,SIE)) Q:'SIE!($G(QUIT)) D PRNT ; S ^TMP($J,"A"_$P(^PSNDF(50.67,SIE,0),"^",2)_"^"_SIE)=""
- Q
- PRT D:($Y+5)>IOSL&('$G(QUIT)) HANG Q:$G(QUIT) S DA=SIE,DIC="^PSNDF(50.67," W ! D EN^DIQ
- Q
- ;
- LISTNDC1 ;LOOK UP PARTIAL NDC
- ;
- F K ^TMP($J) S QUIT=0,DIR(0)="F^1:12",DIR("A")="Select NDC ",DIC("W")="S PSNTDRUG=Y D GETTIER^PSNACT(PSNTDRUG)" D ^DIR Q:$D(DIRUT) S PSN1=Y,PSN=Y D
- .I $D(^PSNDF(50.67,"NDC",PSN1)) S DA=0 F S DA=$O(^PSNDF(50.67,"NDC",PSN1,DA)) S:'DA QUIT=1 Q:QUIT S DIC="^PSNDF(50.67," W ! D EN^DIQ
- .Q:QUIT
- .I PSN1?."0".E S PSN1=PSN1_"/"
- .I PSN1?.N,PSN1=+PSN1 S PSN1=$$LJ^XLFSTR(PSN1,12,0)-1
- .S ZCT=0 F Q:QUIT S PSN1=$O(^PSNDF(50.67,"NDC",PSN1)),DA=0 Q:$E(PSN1,1,$L(PSN))'=PSN F Q:QUIT S DA=$O(^PSNDF(50.67,"NDC",PSN1,DA)) Q:'DA S ZCT=ZCT+1,^TMP($J,ZCT)=DA W !,$J(ZCT,5)," ",PSN1 D
- ..S MORE=$E($O(^PSNDF(50.67,"NDC",PSN1)),1,$L(PSN))=PSN!$O(^(PSN1,DA)) I ZCT#5&MORE Q
- ..S DIR(0)="NOA^1:"_ZCT,DIR("A")="Choose 1 - "_ZCT_" or ^ to quit " S:MORE DIR("A")=DIR("A")_"or return to see more "
- ..D ^DIR I $D(DUOUT)!$D(DTOUT) S QUIT=1 Q
- ..I Y="" Q
- ..S DA=^TMP($J,Y),QUIT=1,DIC="^PSNDF(50.67," W !! D EN^DIQ Q
- G END
- ;
- PRINT(VAPRDIEN) ; Prints the Va Product field
- ;Input: VAPRDIEN - Internal Entry Number (IEN) in the VA PRODUCT (#50.68) file
- ;
- N QQQ,PSNELIEN,Z0,Z1,Z3,Z5,Z6,Z7,X,PSNELXY,K,ING
- S Z0=^PSNDF(50.68,VAPRDIEN,0)
- S Z1=^PSNDF(50.68,VAPRDIEN,1)
- S Z3=^PSNDF(50.68,VAPRDIEN,3)
- S Z5=$G(^PSNDF(50.68,VAPRDIEN,5))
- S Z6=$G(^PSNDF(50.68,VAPRDIEN,6,1,0))
- S Z7=$G(^PSNDF(50.68,VAPRDIEN,7))
- S QQQ=$P(Z1,"^",5) D GCN
- W !,"VA Product Name: ",$P(Z0,"^"),$$DT($P(Z7,"^",3))
- W !,"VA Generic Name: ",$P(^PSNDF(50.6,+$P(Z0,"^",2),0),"^")
- D NDOSE(VAPRDIEN)
- W !,"National Formulary Name: ",$P(Z0,"^",6)
- W !,"VA Print Name: ",$P(Z1,"^")
- W !,"VA Product Identifier: ",$P(Z1,"^",2)," Transmit to CMOP: ",$S($P(Z1,"^",3):"Yes",1:"No")," VA Dispense Unit: ",$P($G(^PSNDF(50.64,+$P(Z1,"^",4),0)),"^")
- W !,"PMIS: ",PMIS,!,"Active Ingredients: "
- S (K,QUIT)=0 F S K=$O(^PSNDF(50.68,VAPRDIEN,2,K)) Q:'K D Q:$G(QUIT)
- . S (PSNELXY,X)=^PSNDF(50.68,VAPRDIEN,2,K,0),ING=^PS(50.416,K,0)
- . S:$P(ING,"^",2) ING=^PS(50.416,$P(ING,"^",2),0)
- . W ?23,$P(ING,"^")," Strength: ",$P(PSNELXY,"^",2)," Units: ",$P($G(^PS(50.607,+$P(PSNELXY,"^",3),0)),"^")
- . D:($Y+5)>IOSL&'QUIT HANG Q:$G(QUIT) W !
- Q:$G(QUIT)
- W !,"Primary VA Drug Class: ",$P($G(^PS(50.605,+Z3,0),"Unknown"),"^")
- W !,"Secondary VA Drug Class: "
- S (K,QUIT)=0 F S K=$O(^PSNDF(50.68,VAPRDIEN,4,K)) Q:'K D Q:$G(QUIT)
- . W ?26,$P($G(^PS(50.605,+K,0),"Unknown"),"^")
- . D:($Y+5)>IOSL&'QUIT HANG Q:$G(QUIT) W !
- Q:$G(QUIT)
- D:($Y+5)>IOSL HANG Q:$G(QUIT)
- W !,"CS Federal Schedule: "_$S($P($G(^PSNDF(50.68,VAPRDIEN,7)),"^")]"":$P(^PSNDF(50.68,VAPRDIEN,7),"^"),1:"") D EXPAN(VAPRDIEN)
- D:($Y+5)>IOSL HANG Q:$G(QUIT)
- W !,"National Formulary Indicator: ",$S($P(Z5,"^"):"Yes",1:"No")
- D:($Y+5)>IOSL HANG Q:$G(QUIT)
- D FD(VAPRDIEN) ;ppsn
- D:($Y+5)>IOSL HANG Q:$G(QUIT)
- W !,"National Formulary Restriction: ",! D NFIP(VAPRDIEN) Q:$G(QUIT)
- D:($Y+5)>IOSL HANG Q:$G(QUIT)
- D FDT(VAPRDIEN) Q:$G(QUIT) ;ppsn - formulary designator text
- D:($Y+5)>IOSL HANG Q:$G(QUIT)
- D CPTIER(VAPRDIEN) ; Copay Tier
- D:($Y+5)>IOSL HANG Q:$G(QUIT)
- I $G(^PSNDF(50.68,VAPRDIEN,8)) W !,"Exclude Drg-Drg Interaction Ck: Yes (No check for Drug-Drug Interactions)"
- D:($Y+5)>IOSL HANG Q:$G(QUIT)
- D OVEX(VAPRDIEN)
- D:($Y+5)>IOSL HANG Q:$G(QUIT)
- D CLEFF^PSNCLEHW(VAPRDIEN,$G(QUIT))
- D:($Y+5)>IOSL HANG Q:$G(QUIT)
- D POSDOS(VAPRDIEN)
- D:($Y+5)>IOSL HANG Q:$G(QUIT)
- W !,"Maximum Days Supply: ",$$GET1^DIQ(50.68,VAPRDIEN,32)
- D:($Y+5)>IOSL HANG Q:$G(QUIT)
- D HAZWASTE^PSNCLEHW(VAPRDIEN)
- D:($Y+5)>IOSL HANG Q:$G(QUIT)
- D CODSYS(VAPRDIEN)
- W ! D HANG
- Q
- ;
- CMOP K DIC S DIC="^PSNDF(50.68,",DIC(0)="QEAZ",D="C",DIC("A")="CMOP ID: ",DIC("W")="S PSNTDRUG=Y D GETTIER^PSNACT(PSNTDRUG)" D MIX^DIC1 Q:Y<0 S IEN=+Y D PRINT(IEN) F SIE=0:0 S SIE=$O(^PSNDF(50.68,"ANDC",IEN,SIE)) Q:'SIE D PRNT
- Q
- HANG K DIR S DIR(0)="E",DIR("A")="Press return to continue or '^' to exit" D ^DIR W @IOF S $X=0 S:Y'=1 QUIT=1
- Q
- PRNT D:($Y+5)>IOSL&('$G(QUIT)) HANG Q:$G(QUIT)
- S NDX=^PSNDF(50.67,SIE,0)
- W !!,"NDC: ",$P(NDX,"^",2)," UPN: ",$P(NDX,"^",3),!,"VA Product Name: ",$P(^PSNDF(50.68,$P(NDX,"^",6),0),"^"),!,"Manufacturer: ",$P($G(^PS(55.95,+$P(NDX,"^",4),0)),"^")," Trade Name: ",$P(NDX,"^",5),!,"Route: "
- S SIE1=0 F S SIE1=$O(^PSNDF(50.67,SIE,1,SIE1)) Q:'SIE1 W $P(^(SIE1,0),"^")
- W !,"Package Size: ",$P(^PS(50.609,$P(NDX,"^",8),0),"^")," Package Type: ",$P(^PS(50.608,$P(NDX,"^",9),0),"^")
- Q
- PAD S ANS=Y F VV=1:1:3 S VV1=$S(VV=1:6,VV=2:4,VV=3:2) D PAD1
- S ANS=$P(ANS,"-",1)_$P(ANS,"-",2)_$P(ANS,"-",3) K VV,VV1
- S ANS=$TR(ANS,"-"),X=ANS
- Q
- PAD1 I $L($P(ANS,"-",VV))<VV1 S $P(ANS,"-",VV)=$E("0000000",1,VV1-$L($P(ANS,"-",VV)))_$P(ANS,"-",VV)
- Q
- DT(Y) ;Inactivation Date display
- X:Y ^DD("DD") Q $S(Y]"":IORVON_" ***INACTIVE: "_Y_" ***"_IORVOFF,1:"")
- Q
- GCN I QQQ']"" S PMIS="None"
- I QQQ]"",'$D(^PS(50.623,"B",QQQ)) S PMIS="None"
- I QQQ]"",$D(^PS(50.623,"B",QQQ)) S MAP=$O(^PS(50.623,"B",QQQ,0)),ENG=$P(^PS(50.623,MAP,0),"^",2),PMIS=$P(^PS(50.621,+ENG,0),"^")
- Q
- I QQQ]"",$D(^PS(50.623,"B",QQQ)) S MAP=$O(^PS(50.623,"B",QQQ,0)),ENG=$P(^PS(50.623,MAP,0),"^",2),PMIS=$P(^PS(50.621,+ENG,0),"^")
- Q
- ;
- NDOSE(PSNELXXX) ;New Dose Form/Strength/Unit display added with patch PSN*4*169
- N PSNELSTL,PSNELUNL,PSNELZER
- S PSNELZER=$G(^PSNDF(50.68,PSNELXXX,0))
- I '$P(PSNELZER,"^",3) W !,"Dose Form: "
- I $P(PSNELZER,"^",3) W !,"Dose Form: ",$P($G(^PS(50.606,+$P(PSNELZER,"^",3),0)),"^")_$S($P($G(^PS(50.606,+$P(PSNELZER,"^",3),1)),"^")=1:" (Exclude from Dosing Cks)",1:"")
- S PSNELSTL=$L($P(PSNELZER,"^",4))
- I $P(PSNELZER,"^",5) S PSNELUNL=$L($P($G(^PS(50.607,+$P(PSNELZER,"^",5),0)),"^"))
- I '$P(PSNELZER,"^",5) S PSNELUNL=0
- I (PSNELSTL+PSNELUNL)<62 W !,"Strength: ",$P(PSNELZER,"^",4)," Units: ",$S($P(PSNELZER,"^",5):$P($G(^PS(50.607,+$P(PSNELZER,"^",5),0)),"^"),1:"") Q
- W !,"Strength: ",$P(PSNELZER,"^",4)
- W !,"Units: " I PSNELUNL<72 W $S($P(PSNELZER,"^",5):$P($G(^PS(50.607,+$P(PSNELZER,"^",5),0)),"^"),1:"") Q
- W !," "_$P($G(^PS(50.607,+$P(PSNELZER,"^",5),0)),"^")
- Q
- ;
- OVEX(PSNELORX) ;New Override Dose Form display added with patch PSN*4*169
- N PSNELDFF
- W !,"Override DF Exclude from Dosage Checks: "_$S($P($G(^PSNDF(50.68,PSNELORX,9)),"^")=1:"Yes",$P($G(^PSNDF(50.68,PSNELORX,9)),"^")=0:"No",1:"") I $P($G(^PSNDF(50.68,PSNELORX,9)),"^")=1 D
- .S PSNELDFF=$P($G(^PSNDF(50.68,PSNELORX,0)),"^",3)
- .I 'PSNELDFF Q
- .I '$D(^PS(50.606,PSNELDFF,0)) Q
- .I $P($G(^PS(50.606,PSNELDFF,1)),"^")=1 W " (Dosage Checks shall be performed)" Q
- .I $P($G(^PS(50.606,PSNELDFF,1)),"^")=0 W " (No dosage checks performed)"
- Q
- CPTIER(VAPRD) ;
- ; Input: VAPRD - VA PRODUCT (#50.68) entry IEN
- N CPDATE,X D NOW^%DTC S CPDATE=X S PSNTIER=$$CPTIER^PSNAPIS(VAPRD,CPDATE,"",1) K CPDATE,X
- ; PSNTIER = Copay Tier^Effective Date^End Date
- W !,"Copay Tier: ",$P(PSNTIER,"^",1)
- W !,"Copay Effective Date: " S Y=$P(PSNTIER,"^",2) D DD^%DT W Y K Y
- W !
- Q
- EXPAN(PSNELFZA) ;
- N PSNELFZB,PSNELFZC
- I $P($G(^PSNDF(50.68,PSNELFZA,7)),"^")="" Q
- S PSNELFZB=PSNELFZA_"," S PSNELFZC=$$GET1^DIQ(50.68,PSNELFZB,19)
- W " "_$G(PSNELFZC)
- Q
- NFIP(PSNELFJ) ;
- N PSNELFJZ,PSNELFJC
- S PSNELFJC=0
- F PSNELFJZ=0:0 S PSNELFJZ=$O(^PSNDF(50.68,PSNELFJ,6,PSNELFJZ)) Q:'PSNELFJZ!($G(QUIT)) D
- .I PSNELFJC W !
- .W $G(^PSNDF(50.68,PSNELFJ,6,PSNELFJZ,0))
- .S PSNELFJC=1
- .D:($Y+5)>IOSL HANG
- I '$G(QUIT),$G(PSNELFJC) W !
- Q
- ;
- POSDOS(VAPRD) ; Dispaly Possible Dosage Auto-Create Setting fields
- ; Input: VAPRD - VA PRODUCT (#50.68) entry IEN
- ;
- N POSDOS Q:'$G(VAPRD)
- S POSDOS=$$POSDOS^PSNAPIS(VAPRD)
- W !!,"Auto-Create Default Possible Dosage? ",$S($P(POSDOS,"^")="Y":"Yes",1:"No")
- I $P(POSDOS,"^")="N" D
- . W !," Possible Dosages To Auto-Create: ",$S($P(POSDOS,"^",2)="N":"No Possible Dosages",$P(POSDOS,"^",2)="O":"1x Possible Dosage",$P(POSDOS,"^",2)="B":"1x and 2x Possible Dosages",1:"")
- . I ($P(POSDOS,"^",2)'="N") D
- . . W !," Package: ",$S($P(POSDOS,"^",3)="O":"Outpatient",$P(POSDOS,"^",3)="I":"Inpatient",$P(POSDOS,"^",3)="IO":"Both Inpatient and Outpatient",1:"")
- Q
- ;
- CODSYS(PSNCIEN) ;CODING SYSTEM
- N I,J,PSNCODX,PSNCODJ,PSNRXCUI S PSNCODX=0
- F I=1:1 S PSNCODX=$O(^PSNDF(50.68,PSNCIEN,11,PSNCODX)) Q:PSNCODX="B"!(PSNCODX="") D
- . S PSNRXCUI=$G(^PSNDF(50.68,PSNCIEN,11,PSNCODX,0)) Q:PSNRXCUI'="RxNorm"
- . W !!,"Coding System: ",$P(^PSNDF(50.68,PSNCIEN,11,PSNCODX,0),"^",1) S PSNCODJ=0
- . F J=1:1 S PSNCODJ=$O(^PSNDF(50.68,PSNCIEN,11,PSNCODX,1,PSNCODJ)) Q:PSNCODJ="B"!(PSNCODJ="") D
- .. W !,"Code: ",$P(^PSNDF(50.68,PSNCIEN,11,PSNCODX,1,PSNCODJ,0),"^",1)
- W !
- Q
- ;
- GETTIERN(PSNCTNDC) ;Get copay tier by NDC; called by DIC to get copay tier for today's date
- N CPDATE,X,PSSCP,VAPID,VAPNAM,PSNINACT,PSNCONVD,PSNFD
- D NOW^%DTC S CPDATE=$P(%,".")
- S VAPID=$$GET1^DIQ(50.67,PSNCTNDC,5,"I")
- I PROMPT="UPN"!(PROMPT="NDC") S VAPNAM=$$GET1^DIQ(50.68,VAPID,.01) W " ",VAPNAM
- S PSNFD=$$GET1^DIQ(50.68,VAPID,109)
- W:PSNFD'="" " "_PSNFD
- S PSSCP=$$CPTIER^PSNAPIS(VAPID,CPDATE) K CPDATE,X
- I $P(PSSCP,"^")'="" W " Tier ",$P(PSSCP,"^")
- S PSNINACT=$$GET1^DIQ(50.67,PSNCTNDC,7,"I") ;inactive date
- S:$G(PSNINACT) PSNCONVD=$$DATE^PSNLOOK(PSNINACT)
- W:$G(PSNCONVD)'="" " "_PSNCONVD
- Q
- ;
- GETTIER(PSNTDRUG) ;called by DIC; look up copay tier by va product for the current date
- N CPDATE,X,PSSCP,PSNINACT,PSNCONVD,PSNFD
- S PSNFD=$$GET1^DIQ(50.68,PSNTDRUG,109)
- W:PSNFD'="" " "_PSNFD
- D NOW^%DTC S CPDATE=$P(%,".")
- S PSSCP=$$CPTIER^PSNAPIS(PSNTDRUG,CPDATE,"",1) K CPDATE,X
- I $P(PSSCP,"^")'="" W " Tier ",$P(PSSCP,"^")
- S PSNINACT=$$GET1^DIQ(50.68,PSNTDRUG,21,"I") ;inactive date
- S:$G(PSNINACT) PSNCONVD=$$DATE^PSNLOOK(PSNINACT)
- W:$G(PSNCONVD)'="" " "_PSNCONVD
- Q
- ;
- FD(PSNELFJ) ;DBIA #6754
- N PSSFD
- S PSSFD="",PSSFD=$$GET1^DIQ(50.68,PSNELFJ,109) ;ppsn
- W:PSSFD'="" !,"Formulary Designator: "_PSSFD
- Q
- ;
- FDR(PSNELFJ) ;DBIA #6754
- N PSNFD
- S PSNFD="",PSNFD=$$GET1^DIQ(50.68,PSNELFJ,109) ;ppsn
- Q PSNFD
- ;
- FDT(PSNELFJ) ;DBIA #6754
- N PSNFDTXT S PSNFDTXT=0 Q:'$O(^PSNDF(50.68,PSNELFJ,5.1,PSNFDTXT))
- N X,DIWL,DIWR,DIWF,PSNJ,PSNDND,FDTCNT,FDTCNT2,PSNTEXT
- K ^UTILITY($J,"W")
- S (PSNDND,PSNJ)=0,PSNTEXT=""
- F S PSNJ=$O(^PSNDF(50.68,PSNELFJ,5.1,PSNJ)) Q:PSNJ="" D
- .S PSNDND=$G(^PSNDF(50.68,PSNELFJ,5.1,PSNJ,0)) I $TR(PSNDND," ")'="" S PSNTEXT=1
- Q:'PSNTEXT
- S DIWL=15,DIWR=79,(PSNDND,PSNJ)=0,FDTCNT2=1
- F S PSNJ=$O(^PSNDF(50.68,PSNELFJ,5.1,PSNJ)) Q:PSNJ="" D
- .S PSNDND=$G(^PSNDF(50.68,PSNELFJ,5.1,PSNJ,0))
- .S X=PSNDND D ^DIWP
- ;
- S FDTCNT=0 F FDTCNT=0:0 S FDTCNT=$O(^UTILITY($J,"W",DIWL,FDTCNT)) Q:'FDTCNT D
- .I FDTCNT2=1 W !,"Product Text: "
- .I FDTCNT2>1 W !," "
- .W $G(^UTILITY($J,"W",DIWL,FDTCNT,0)) S FDTCNT2=2
- K ^UTILITY($J,"W")
- Q
- ;
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSNACT 15228 printed Feb 18, 2025@23:49:48 Page 2
- PSNACT ;BIR/DMA&WRT-inquiries by VAPN, CMOP ID, or NDC ;07/02/03 14:01
- +1 ;;4.0;NATIONAL DRUG FILE;**22,35,47,62,65,70,160,169,262,296,429,492,396**; 30 Oct 98;Build 190
- +2 ;
- +3 ;Reference to ^PS(50.606 supported by DBIA #2174
- +4 ;Reference to ^PSNAPIS supported by DBIA #2531
- +5 ;
- +6 IF '$DATA(IORVON)
- SET X="IORVON;IORVOFF"
- DO ENDR^%ZISS
- +7 KILL DIC,DIR
- FOR ZXX=0:0
- WRITE !
- DO TEXT
- DO ASKIT
- if $DATA(DIRUT)
- QUIT
- +8 KILL QUIT,DIR,DIC,OLDDA,PROMPT,J,I,IEN,PPP,Y,Y1,Y3,Y5,Y6,Y7,Z0,Z1,Z3,Z5,Z6,Z7,ZA,ZXX,ASK,NDX,SIE,PSN,PSN1,MORE,SIE1
- +9 NEW PMIS,QQQ,ENG,MAP,D,ANS,ZCT,DYAYGO,DUOUT,DTOUT,PSNTIER
- +10 QUIT
- TEXT WRITE !,"This option allows you to lookup NDF file information three ways (VA Product",!,"Name, NDC, or CMOP ID number).",!
- +1 QUIT
- ASKIT SET DIR(0)="SA^VA:VA PRODUCT;N:NDC;C:CMOP ID"
- SET DIR("A")="LOOKUP BY (VA) PRODUCT, (N)DC, OR (C)MOP ID ? "
- DO ^DIR
- if $DATA(DIRUT)
- GOTO END
- SET ASK=Y(0)
- +1 IF ASK="NDC"
- DO NDC
- +2 IF ASK="VA PRODUCT"
- DO LISTNDC
- +3 IF ASK="CMOP ID"
- DO CMOP
- +4 QUIT
- +5 ;
- NDC ;OR UPN
- +1 KILL PROMPT
- SET DIR(0)="SA^N:NDC;U:UPN"
- SET DIR("A")="NDC (N) or UPN (U) ? "
- DO ^DIR
- if $DATA(DIRUT)
- GOTO END
- SET PROMPT=Y(0)
- +2 IF PROMPT="NDC"
- SET DIR(0)="F"
- SET DIR("A")="Enter NDC with or without Dashes (-)"
- DO ^DIR
- if $DATA(DIRUT)
- GOTO END
- if X["-"
- DO PAD
- SET DIC=50.67
- SET DIC(0)="EQZN"
- SET D=PROMPT
- SET DIC("W")="S PSNCTNDC=Y D GETTIERN^PSNACT(PSNCTNDC)"
- DO IX^DIC
- if Y<0
- QUIT
- SET DA=+Y
- SET NDF=Y(0)
- DO LKNDC
- +3 IF PROMPT="UPN"
- SET DIC=50.67
- SET DIC(0)="AEQZN"
- SET DIC("A")="Select "_PROMPT_":"_" "
- SET D=PROMPT
- SET DIC("W")="S PSNCTNDC=Y D GETTIERN^PSNACT(PSNCTNDC)"
- DO IX^DIC
- if Y<0
- QUIT
- SET DA=+Y
- SET NDF=Y(0)
- DO LKNDC
- +4 QUIT
- LKNDC WRITE @IOF,!,"NDC: ",$PIECE(NDF,"^",2),$$DT($PIECE(NDF,"^",7))," UPN: ",$PIECE(NDF,"^",3),!,"VA Product Name: ",...
- ... $PIECE(^PSNDF(50.68,$PIECE(NDF,"^",6),0),"^"),!,"Manufacturer: ",$PIECE($GET(^PS(55.95,+$PIECE(NDF,"^",4),0)),"^")," Trade Name: ",$PIECE(NDF,"^",5),!,"Route: "
- +1 SET K=0
- FOR
- SET K=$ORDER(^PSNDF(50.67,DA,1,K))
- if 'K
- QUIT
- WRITE $PIECE(^(K,0),"^")," "
- +2 WRITE !,"Package Size: ",$PIECE(^PS(50.609,$PIECE(NDF,"^",8),0),"^")," Package Type: ",$PIECE(^PS(50.608,$PIECE(NDF,"^",9),0),"^")
- +3 SET ZA=$PIECE(NDF,"^",6)
- DO PRINT(ZA)
- +4 QUIT
- END KILL DA,DA,DIC,DIE,DIR,DR,IN,ING,J,K,L,NEW,NDF,OLD,OLDDA,PROMPT,X,Y,Y1,Y3,Y7,^TMP($JOB)
- QUIT
- +1 ;
- PRODI ;INQUIRE INTO 50.68
- +1 FOR
- SET DIC="^PSNDF(50.68,"
- SET DIC(0)="AEQM"
- DO ^DIC
- if Y<0
- QUIT
- SET DA=+Y
- DO EN^DIQ
- +2 KILL DA,DIC,X,Y
- QUIT
- +3 ;
- NDCI ;INQUIRE INTO 50.67
- +1 SET DIR(0)="SA^N:NDC;U:UPN;T:TRADE;P:PRODUCT"
- SET DIR("A")="NDC (N), UPN (U), Trade name (T), or Product (P) "
- DO ^DIR
- if $DATA(DIRUT)
- GOTO END
- SET PROMPT=Y(0)
- if PROMPT["PRO"
- GOTO LISTNDC
- if PROMPT="NDC"
- GOTO LISTNDC1
- IF PROMPT["T"
- SET PROMPT="T"
- +2 FOR
- SET DIC="^PSNDF(50.67,"
- SET DIC(0)="AEQZS"
- SET DIC("A")="Select "_PROMPT
- if PROMPT="T"
- SET DIC("A")=DIC("A")_"rade name"
- SET DIC("A")=DIC("A")_" "
- SET D=PROMPT
- DO IX^DIC
- if Y<0
- QUIT
- SET DA=+Y
- DO EN^DIQ
- +3 KILL DA,DIC,DIR,PROMPT,X,Y
- QUIT
- +4 ;
- LINK ;LINK NDCS OR UPNS
- +1 SET DIR(0)="SA^N:NDC;U:UPN"
- SET DIR("A")="NDC (N) or UPN (U) "
- SET DIR("B")="NDC"
- DO ^DIR
- if $DATA(DIRUT)
- GOTO END
- SET PROMPT=Y(0)
- +2 FOR
- if $DATA(DIRUT)!(Y<0)
- QUIT
- SET DIC=50.67
- SET DIC(0)="AEQZ"
- SET DIC("A")="Enter Current "_PROMPT_" "
- SET D=PROMPT
- DO IX^DIC
- if Y<0
- QUIT
- SET DA=+Y
- SET OLD=$PIECE(Y(0),"^",$SELECT(PROMPT="NDC":2,1:3))
- Begin DoDot:1
- +3 KILL DIR
- SET DIR(0)="F^"_$SELECT(PROMPT="NDC":"12:12",1:"1:40")_"^W:$D(^PSNDF(50.67,PROMPT,X)) !!,""That "_PROMPT_" already exists"",! K:$D(^PSNDF(50.67,PROMPT,X)) X"
- SET DIR("A")="Enter a new "_PROMPT_" "
- DO ^DIR
- KILL DIR
- if $DATA(DIRUT)
- QUIT
- SET NEW=Y
- +4 IF PROMPT="NDC"
- Begin DoDot:2
- +5 SET IN=$ORDER(^PSNDF(50.67,DA,2,"B",NEW,0))
- IF IN
- SET DIR(0)="Y"
- WRITE !,"Those NDCs are already linked"
- SET DIR("A")="Do you want to unlink them "
- DO ^DIR
- if $DATA(DIRUT)
- QUIT
- if 'Y
- QUIT
- +6 IF IN
- SET DA(1)=DA
- SET DA=IN
- SET DIE="^PSNDF(50.67,"_DA(1)_",2,"
- SET DR=".01///@;"
- DO ^DIE
- WRITE !,"Unlinked",!
- QUIT
- +7 IF 'IN
- SET DIE="^PSNDF(50.67,"
- SET DR="1////"_NEW
- DO ^DIE
- KILL DD,DO
- SET DA(1)=DA
- SET DIC="^PSNDF(50.67,"_DA(1)_",2,"
- SET DIC(0)="L"
- SET DLAYGO=50.67
- SET DIC("P")=$PIECE(^DD(50.67,11,0),"^",2)
- SET X=OLD
- DO ^DIC
- WRITE !,"Linked",!
- QUIT
- End DoDot:2
- +8 IF PROMPT="UPN"
- Begin DoDot:2
- +9 SET IN=$ORDER(^PSNDF(50.67,DA,3,"B",NEW,0))
- IF IN
- SET DIR(0)="Y"
- WRITE !,"Those UPNs are already linked"
- SET DIR("A")="Do you want to unlink them "
- DO ^DIR
- if $DATA(DIRUT)
- QUIT
- if 'Y
- QUIT
- +10 SET DA(1)=DA
- SET DA=IN
- SET DIE="^PSNDF(50.67,"_DA(1)_",3,"
- SET DR=".01///@;"
- DO ^DIE
- WRITE !,"Unlinked",!
- QUIT
- +11 IF 'IN
- SET DIE="^PSNDF(50.67,"
- SET DR="1////"_NEW
- DO ^DIE
- KILL DD,DO
- SET DA(1)=DA
- SET DIC="^PSNDF(50.67,"_DA(1)_",3,"
- SET DIC(0)="L"
- SET DLAYGO=50.67
- SET DIC("P")=$PIECE(^DD(50.67,12,0),"^",2)
- SET X=OLD
- DO ^DIC
- WRITE !,"Linked",!
- QUIT
- End DoDot:2
- End DoDot:1
- +12 GOTO LINK
- +13 ;
- LISTNDC ;LOOK UP NDCS BY PRODUCT
- +1 KILL L,DA,^TMP($JOB),DIC
- +2 SET DIC=50.68
- SET DIC(0)="AQEMZ"
- SET DIC("W")="S PSNTDRUG=Y D GETTIER^PSNACT(PSNTDRUG)"
- DO ^DIC
- if Y<0
- GOTO END
- +3 ; S ^TMP($J,"A"_$P(^PSNDF(50.67,SIE,0),"^",2)_"^"_SIE)=""
- SET IEN=+Y
- WRITE @IOF
- DO PRINT(IEN)
- if $GET(QUIT)
- QUIT
- FOR SIE=0:0
- SET SIE=$ORDER(^PSNDF(50.68,"ANDC",IEN,SIE))
- if 'SIE!($GET(QUIT))
- QUIT
- DO PRNT
- +4 QUIT
- PRT if ($Y+5)>IOSL&('$GET(QUIT))
- DO HANG
- if $GET(QUIT)
- QUIT
- SET DA=SIE
- SET DIC="^PSNDF(50.67,"
- WRITE !
- DO EN^DIQ
- +1 QUIT
- +2 ;
- LISTNDC1 ;LOOK UP PARTIAL NDC
- +1 ;
- +2 FOR
- KILL ^TMP($JOB)
- SET QUIT=0
- SET DIR(0)="F^1:12"
- SET DIR("A")="Select NDC "
- SET DIC("W")="S PSNTDRUG=Y D GETTIER^PSNACT(PSNTDRUG)"
- DO ^DIR
- if $DATA(DIRUT)
- QUIT
- SET PSN1=Y
- SET PSN=Y
- Begin DoDot:1
- +3 IF $DATA(^PSNDF(50.67,"NDC",PSN1))
- SET DA=0
- FOR
- SET DA=$ORDER(^PSNDF(50.67,"NDC",PSN1,DA))
- if 'DA
- SET QUIT=1
- if QUIT
- QUIT
- SET DIC="^PSNDF(50.67,"
- WRITE !
- DO EN^DIQ
- +4 if QUIT
- QUIT
- +5 IF PSN1?."0".E
- SET PSN1=PSN1_"/"
- +6 IF PSN1?.N
- IF PSN1=+PSN1
- SET PSN1=$$LJ^XLFSTR(PSN1,12,0)-1
- +7 SET ZCT=0
- FOR
- if QUIT
- QUIT
- SET PSN1=$ORDER(^PSNDF(50.67,"NDC",PSN1))
- SET DA=0
- if $EXTRACT(PSN1,1,$LENGTH(PSN))'=PSN
- QUIT
- FOR
- if QUIT
- QUIT
- SET DA=$ORDER(^PSNDF(50.67,"NDC",PSN1,DA))
- if 'DA
- QUIT
- SET ZCT=ZCT+1
- SET ^TMP($JOB,ZCT)=DA
- WRITE !,$JUSTIFY(ZCT,5)," ",PSN1
- Begin DoDot:2
- +8 SET MORE=$EXTRACT($ORDER(^PSNDF(50.67,"NDC",PSN1)),1,$LENGTH(PSN))=PSN!$ORDER(^(PSN1,DA))
- IF ZCT#5&MORE
- QUIT
- +9 SET DIR(0)="NOA^1:"_ZCT
- SET DIR("A")="Choose 1 - "_ZCT_" or ^ to quit "
- if MORE
- SET DIR("A")=DIR("A")_"or return to see more "
- +10 DO ^DIR
- IF $DATA(DUOUT)!$DATA(DTOUT)
- SET QUIT=1
- QUIT
- +11 IF Y=""
- QUIT
- +12 SET DA=^TMP($JOB,Y)
- SET QUIT=1
- SET DIC="^PSNDF(50.67,"
- WRITE !!
- DO EN^DIQ
- QUIT
- End DoDot:2
- End DoDot:1
- +13 GOTO END
- +14 ;
- PRINT(VAPRDIEN) ; Prints the Va Product field
- +1 ;Input: VAPRDIEN - Internal Entry Number (IEN) in the VA PRODUCT (#50.68) file
- +2 ;
- +3 NEW QQQ,PSNELIEN,Z0,Z1,Z3,Z5,Z6,Z7,X,PSNELXY,K,ING
- +4 SET Z0=^PSNDF(50.68,VAPRDIEN,0)
- +5 SET Z1=^PSNDF(50.68,VAPRDIEN,1)
- +6 SET Z3=^PSNDF(50.68,VAPRDIEN,3)
- +7 SET Z5=$GET(^PSNDF(50.68,VAPRDIEN,5))
- +8 SET Z6=$GET(^PSNDF(50.68,VAPRDIEN,6,1,0))
- +9 SET Z7=$GET(^PSNDF(50.68,VAPRDIEN,7))
- +10 SET QQQ=$PIECE(Z1,"^",5)
- DO GCN
- +11 WRITE !,"VA Product Name: ",$PIECE(Z0,"^"),$$DT($PIECE(Z7,"^",3))
- +12 WRITE !,"VA Generic Name: ",$PIECE(^PSNDF(50.6,+$PIECE(Z0,"^",2),0),"^")
- +13 DO NDOSE(VAPRDIEN)
- +14 WRITE !,"National Formulary Name: ",$PIECE(Z0,"^",6)
- +15 WRITE !,"VA Print Name: ",$PIECE(Z1,"^")
- +16 WRITE !,"VA Product Identifier: ",$PIECE(Z1,"^",2)," Transmit to CMOP: ",$SELECT($PIECE(Z1,"^",3):"Yes",1:"No")," VA Dispense Unit: ",$PIECE($GET(^PSNDF(50.64,+$PIECE(Z1,"^",4),0)),"^")
- +17 WRITE !,"PMIS: ",PMIS,!,"Active Ingredients: "
- +18 SET (K,QUIT)=0
- FOR
- SET K=$ORDER(^PSNDF(50.68,VAPRDIEN,2,K))
- if 'K
- QUIT
- Begin DoDot:1
- +19 SET (PSNELXY,X)=^PSNDF(50.68,VAPRDIEN,2,K,0)
- SET ING=^PS(50.416,K,0)
- +20 if $PIECE(ING,"^",2)
- SET ING=^PS(50.416,$PIECE(ING,"^",2),0)
- +21 WRITE ?23,$PIECE(ING,"^")," Strength: ",$PIECE(PSNELXY,"^",2)," Units: ",$PIECE($GET(^PS(50.607,+$PIECE(PSNELXY,"^",3),0)),"^")
- +22 if ($Y+5)>IOSL&'QUIT
- DO HANG
- if $GET(QUIT)
- QUIT
- WRITE !
- End DoDot:1
- if $GET(QUIT)
- QUIT
- +23 if $GET(QUIT)
- QUIT
- +24 WRITE !,"Primary VA Drug Class: ",$PIECE($GET(^PS(50.605,+Z3,0),"Unknown"),"^")
- +25 WRITE !,"Secondary VA Drug Class: "
- +26 SET (K,QUIT)=0
- FOR
- SET K=$ORDER(^PSNDF(50.68,VAPRDIEN,4,K))
- if 'K
- QUIT
- Begin DoDot:1
- +27 WRITE ?26,$PIECE($GET(^PS(50.605,+K,0),"Unknown"),"^")
- +28 if ($Y+5)>IOSL&'QUIT
- DO HANG
- if $GET(QUIT)
- QUIT
- WRITE !
- End DoDot:1
- if $GET(QUIT)
- QUIT
- +29 if $GET(QUIT)
- QUIT
- +30 if ($Y+5)>IOSL
- DO HANG
- if $GET(QUIT)
- QUIT
- +31 WRITE !,"CS Federal Schedule: "_$SELECT($PIECE($GET(^PSNDF(50.68,VAPRDIEN,7)),"^")]"":$PIECE(^PSNDF(50.68,VAPRDIEN,7),"^"),1:"")
- DO EXPAN(VAPRDIEN)
- +32 if ($Y+5)>IOSL
- DO HANG
- if $GET(QUIT)
- QUIT
- +33 WRITE !,"National Formulary Indicator: ",$SELECT($PIECE(Z5,"^"):"Yes",1:"No")
- +34 if ($Y+5)>IOSL
- DO HANG
- if $GET(QUIT)
- QUIT
- +35 ;ppsn
- DO FD(VAPRDIEN)
- +36 if ($Y+5)>IOSL
- DO HANG
- if $GET(QUIT)
- QUIT
- +37 WRITE !,"National Formulary Restriction: ",!
- DO NFIP(VAPRDIEN)
- if $GET(QUIT)
- QUIT
- +38 if ($Y+5)>IOSL
- DO HANG
- if $GET(QUIT)
- QUIT
- +39 ;ppsn - formulary designator text
- DO FDT(VAPRDIEN)
- if $GET(QUIT)
- QUIT
- +40 if ($Y+5)>IOSL
- DO HANG
- if $GET(QUIT)
- QUIT
- +41 ; Copay Tier
- DO CPTIER(VAPRDIEN)
- +42 if ($Y+5)>IOSL
- DO HANG
- if $GET(QUIT)
- QUIT
- +43 IF $GET(^PSNDF(50.68,VAPRDIEN,8))
- WRITE !,"Exclude Drg-Drg Interaction Ck: Yes (No check for Drug-Drug Interactions)"
- +44 if ($Y+5)>IOSL
- DO HANG
- if $GET(QUIT)
- QUIT
- +45 DO OVEX(VAPRDIEN)
- +46 if ($Y+5)>IOSL
- DO HANG
- if $GET(QUIT)
- QUIT
- +47 DO CLEFF^PSNCLEHW(VAPRDIEN,$GET(QUIT))
- +48 if ($Y+5)>IOSL
- DO HANG
- if $GET(QUIT)
- QUIT
- +49 DO POSDOS(VAPRDIEN)
- +50 if ($Y+5)>IOSL
- DO HANG
- if $GET(QUIT)
- QUIT
- +51 WRITE !,"Maximum Days Supply: ",$$GET1^DIQ(50.68,VAPRDIEN,32)
- +52 if ($Y+5)>IOSL
- DO HANG
- if $GET(QUIT)
- QUIT
- +53 DO HAZWASTE^PSNCLEHW(VAPRDIEN)
- +54 if ($Y+5)>IOSL
- DO HANG
- if $GET(QUIT)
- QUIT
- +55 DO CODSYS(VAPRDIEN)
- +56 WRITE !
- DO HANG
- +57 QUIT
- +58 ;
- CMOP KILL DIC
- SET DIC="^PSNDF(50.68,"
- SET DIC(0)="QEAZ"
- SET D="C"
- SET DIC("A")="CMOP ID: "
- SET DIC("W")="S PSNTDRUG=Y D GETTIER^PSNACT(PSNTDRUG)"
- DO MIX^DIC1
- if Y<0
- QUIT
- SET IEN=+Y
- DO PRINT(IEN)
- FOR SIE=0:0
- SET SIE=$ORDER(^PSNDF(50.68,"ANDC",IEN,SIE))
- if 'SIE
- QUIT
- DO PRNT
- +1 QUIT
- HANG KILL DIR
- SET DIR(0)="E"
- SET DIR("A")="Press return to continue or '^' to exit"
- DO ^DIR
- WRITE @IOF
- SET $X=0
- if Y'=1
- SET QUIT=1
- +1 QUIT
- PRNT if ($Y+5)>IOSL&('$GET(QUIT))
- DO HANG
- if $GET(QUIT)
- QUIT
- +1 SET NDX=^PSNDF(50.67,SIE,0)
- +2 WRITE !!,"NDC: ",$PIECE(NDX,"^",2)," UPN: ",$PIECE(NDX,"^",3),!,"VA Product Name: ",$PIECE(^PSNDF(50.68,$PIECE(NDX,"^",6),0),"^"),!,"Manufacturer: ",$PIECE($GET(^PS(55.95,+$PIECE(NDX,"^",4),0)),"^")," Trade Name: ",$PIECE(NDX,"^",5),!,"Route:
- "
- +3 SET SIE1=0
- FOR
- SET SIE1=$ORDER(^PSNDF(50.67,SIE,1,SIE1))
- if 'SIE1
- QUIT
- WRITE $PIECE(^(SIE1,0),"^")
- +4 WRITE !,"Package Size: ",$PIECE(^PS(50.609,$PIECE(NDX,"^",8),0),"^")," Package Type: ",$PIECE(^PS(50.608,$PIECE(NDX,"^",9),0),"^")
- +5 QUIT
- PAD SET ANS=Y
- FOR VV=1:1:3
- SET VV1=$SELECT(VV=1:6,VV=2:4,VV=3:2)
- DO PAD1
- +1 SET ANS=$PIECE(ANS,"-",1)_$PIECE(ANS,"-",2)_$PIECE(ANS,"-",3)
- KILL VV,VV1
- +2 SET ANS=$TRANSLATE(ANS,"-")
- SET X=ANS
- +3 QUIT
- PAD1 IF $LENGTH($PIECE(ANS,"-",VV))<VV1
- SET $PIECE(ANS,"-",VV)=$EXTRACT("0000000",1,VV1-$LENGTH($PIECE(ANS,"-",VV)))_$PIECE(ANS,"-",VV)
- +1 QUIT
- DT(Y) ;Inactivation Date display
- +1 if Y
- XECUTE ^DD("DD")
- QUIT $SELECT(Y]"":IORVON_" ***INACTIVE: "_Y_" ***"_IORVOFF,1:"")
- +2 QUIT
- GCN IF QQQ']""
- SET PMIS="None"
- +1 IF QQQ]""
- IF '$DATA(^PS(50.623,"B",QQQ))
- SET PMIS="None"
- +2 IF QQQ]""
- IF $DATA(^PS(50.623,"B",QQQ))
- SET MAP=$ORDER(^PS(50.623,"B",QQQ,0))
- SET ENG=$PIECE(^PS(50.623,MAP,0),"^",2)
- SET PMIS=$PIECE(^PS(50.621,+ENG,0),"^")
- +3 QUIT
- +4 IF QQQ]""
- IF $DATA(^PS(50.623,"B",QQQ))
- SET MAP=$ORDER(^PS(50.623,"B",QQQ,0))
- SET ENG=$PIECE(^PS(50.623,MAP,0),"^",2)
- SET PMIS=$PIECE(^PS(50.621,+ENG,0),"^")
- +5 QUIT
- +6 ;
- NDOSE(PSNELXXX) ;New Dose Form/Strength/Unit display added with patch PSN*4*169
- +1 NEW PSNELSTL,PSNELUNL,PSNELZER
- +2 SET PSNELZER=$GET(^PSNDF(50.68,PSNELXXX,0))
- +3 IF '$PIECE(PSNELZER,"^",3)
- WRITE !,"Dose Form: "
- +4 IF $PIECE(PSNELZER,"^",3)
- WRITE !,"Dose Form: ",$PIECE($GET(^PS(50.606,+$PIECE(PSNELZER,"^",3),0)),"^")_$SELECT($PIECE($GET(^PS(50.606,+$PIECE(PSNELZER,"^",3),1)),"^")=1:" (Exclude from Dosing Cks)",1:"")
- +5 SET PSNELSTL=$LENGTH($PIECE(PSNELZER,"^",4))
- +6 IF $PIECE(PSNELZER,"^",5)
- SET PSNELUNL=$LENGTH($PIECE($GET(^PS(50.607,+$PIECE(PSNELZER,"^",5),0)),"^"))
- +7 IF '$PIECE(PSNELZER,"^",5)
- SET PSNELUNL=0
- +8 IF (PSNELSTL+PSNELUNL)<62
- WRITE !,"Strength: ",$PIECE(PSNELZER,"^",4)," Units: ",$SELECT($PIECE(PSNELZER,"^",5):$PIECE($GET(^PS(50.607,+$PIECE(PSNELZER,"^",5),0)),"^"),1:"")
- QUIT
- +9 WRITE !,"Strength: ",$PIECE(PSNELZER,"^",4)
- +10 WRITE !,"Units: "
- IF PSNELUNL<72
- WRITE $SELECT($PIECE(PSNELZER,"^",5):$PIECE($GET(^PS(50.607,+$PIECE(PSNELZER,"^",5),0)),"^"),1:"")
- QUIT
- +11 WRITE !," "_$PIECE($GET(^PS(50.607,+$PIECE(PSNELZER,"^",5),0)),"^")
- +12 QUIT
- +13 ;
- OVEX(PSNELORX) ;New Override Dose Form display added with patch PSN*4*169
- +1 NEW PSNELDFF
- +2 WRITE !,"Override DF Exclude from Dosage Checks: "_$SELECT($PIECE($GET(^PSNDF(50.68,PSNELORX,9)),"^")=1:"Yes",$PIECE($GET(^PSNDF(50.68,PSNELORX,9)),"^")=0:"No",1:"")
- IF $PIECE($GET(^PSNDF(50.68,PSNELORX,9)),"^")=1
- Begin DoDot:1
- +3 SET PSNELDFF=$PIECE($GET(^PSNDF(50.68,PSNELORX,0)),"^",3)
- +4 IF 'PSNELDFF
- QUIT
- +5 IF '$DATA(^PS(50.606,PSNELDFF,0))
- QUIT
- +6 IF $PIECE($GET(^PS(50.606,PSNELDFF,1)),"^")=1
- WRITE " (Dosage Checks shall be performed)"
- QUIT
- +7 IF $PIECE($GET(^PS(50.606,PSNELDFF,1)),"^")=0
- WRITE " (No dosage checks performed)"
- End DoDot:1
- +8 QUIT
- CPTIER(VAPRD) ;
- +1 ; Input: VAPRD - VA PRODUCT (#50.68) entry IEN
- +2 NEW CPDATE,X
- DO NOW^%DTC
- SET CPDATE=X
- SET PSNTIER=$$CPTIER^PSNAPIS(VAPRD,CPDATE,"",1)
- KILL CPDATE,X
- +3 ; PSNTIER = Copay Tier^Effective Date^End Date
- +4 WRITE !,"Copay Tier: ",$PIECE(PSNTIER,"^",1)
- +5 WRITE !,"Copay Effective Date: "
- SET Y=$PIECE(PSNTIER,"^",2)
- DO DD^%DT
- WRITE Y
- KILL Y
- +6 WRITE !
- +7 QUIT
- EXPAN(PSNELFZA) ;
- +1 NEW PSNELFZB,PSNELFZC
- +2 IF $PIECE($GET(^PSNDF(50.68,PSNELFZA,7)),"^")=""
- QUIT
- +3 SET PSNELFZB=PSNELFZA_","
- SET PSNELFZC=$$GET1^DIQ(50.68,PSNELFZB,19)
- +4 WRITE " "_$GET(PSNELFZC)
- +5 QUIT
- NFIP(PSNELFJ) ;
- +1 NEW PSNELFJZ,PSNELFJC
- +2 SET PSNELFJC=0
- +3 FOR PSNELFJZ=0:0
- SET PSNELFJZ=$ORDER(^PSNDF(50.68,PSNELFJ,6,PSNELFJZ))
- if 'PSNELFJZ!($GET(QUIT))
- QUIT
- Begin DoDot:1
- +4 IF PSNELFJC
- WRITE !
- +5 WRITE $GET(^PSNDF(50.68,PSNELFJ,6,PSNELFJZ,0))
- +6 SET PSNELFJC=1
- +7 if ($Y+5)>IOSL
- DO HANG
- End DoDot:1
- +8 IF '$GET(QUIT)
- IF $GET(PSNELFJC)
- WRITE !
- +9 QUIT
- +10 ;
- POSDOS(VAPRD) ; Dispaly Possible Dosage Auto-Create Setting fields
- +1 ; Input: VAPRD - VA PRODUCT (#50.68) entry IEN
- +2 ;
- +3 NEW POSDOS
- if '$GET(VAPRD)
- QUIT
- +4 SET POSDOS=$$POSDOS^PSNAPIS(VAPRD)
- +5 WRITE !!,"Auto-Create Default Possible Dosage? ",$SELECT($PIECE(POSDOS,"^")="Y":"Yes",1:"No")
- +6 IF $PIECE(POSDOS,"^")="N"
- Begin DoDot:1
- +7 WRITE !," Possible Dosages To Auto-Create: ",$SELECT($PIECE(POSDOS,"^",2)="N":"No Possible Dosages",$PIECE(POSDOS,"^",2)="O":"1x Possible Dosage",$PIECE(POSDOS,"^",2)="B":"1x and 2x Possible Dosages",1:"")
- +8 IF ($PIECE(POSDOS,"^",2)'="N")
- Begin DoDot:2
- +9 WRITE !," Package: ",$SELECT($PIECE(POSDOS,"^",3)="O":"Outpatient",$PIECE(POSDOS,"^",3)="I":"Inpatient",$PIECE(POSDOS,"^",3)="IO":"Both Inpatient and Outpatient",1:"")
- End DoDot:2
- End DoDot:1
- +10 QUIT
- +11 ;
- CODSYS(PSNCIEN) ;CODING SYSTEM
- +1 NEW I,J,PSNCODX,PSNCODJ,PSNRXCUI
- SET PSNCODX=0
- +2 FOR I=1:1
- SET PSNCODX=$ORDER(^PSNDF(50.68,PSNCIEN,11,PSNCODX))
- if PSNCODX="B"!(PSNCODX="")
- QUIT
- Begin DoDot:1
- +3 SET PSNRXCUI=$GET(^PSNDF(50.68,PSNCIEN,11,PSNCODX,0))
- if PSNRXCUI'="RxNorm"
- QUIT
- +4 WRITE !!,"Coding System: ",$PIECE(^PSNDF(50.68,PSNCIEN,11,PSNCODX,0),"^",1)
- SET PSNCODJ=0
- +5 FOR J=1:1
- SET PSNCODJ=$ORDER(^PSNDF(50.68,PSNCIEN,11,PSNCODX,1,PSNCODJ))
- if PSNCODJ="B"!(PSNCODJ="")
- QUIT
- Begin DoDot:2
- +6 WRITE !,"Code: ",$PIECE(^PSNDF(50.68,PSNCIEN,11,PSNCODX,1,PSNCODJ,0),"^",1)
- End DoDot:2
- End DoDot:1
- +7 WRITE !
- +8 QUIT
- +9 ;
- GETTIERN(PSNCTNDC) ;Get copay tier by NDC; called by DIC to get copay tier for today's date
- +1 NEW CPDATE,X,PSSCP,VAPID,VAPNAM,PSNINACT,PSNCONVD,PSNFD
- +2 DO NOW^%DTC
- SET CPDATE=$PIECE(%,".")
- +3 SET VAPID=$$GET1^DIQ(50.67,PSNCTNDC,5,"I")
- +4 IF PROMPT="UPN"!(PROMPT="NDC")
- SET VAPNAM=$$GET1^DIQ(50.68,VAPID,.01)
- WRITE " ",VAPNAM
- +5 SET PSNFD=$$GET1^DIQ(50.68,VAPID,109)
- +6 if PSNFD'=""
- WRITE " "_PSNFD
- +7 SET PSSCP=$$CPTIER^PSNAPIS(VAPID,CPDATE)
- KILL CPDATE,X
- +8 IF $PIECE(PSSCP,"^")'=""
- WRITE " Tier ",$PIECE(PSSCP,"^")
- +9 ;inactive date
- SET PSNINACT=$$GET1^DIQ(50.67,PSNCTNDC,7,"I")
- +10 if $GET(PSNINACT)
- SET PSNCONVD=$$DATE^PSNLOOK(PSNINACT)
- +11 if $GET(PSNCONVD)'=""
- WRITE " "_PSNCONVD
- +12 QUIT
- +13 ;
- GETTIER(PSNTDRUG) ;called by DIC; look up copay tier by va product for the current date
- +1 NEW CPDATE,X,PSSCP,PSNINACT,PSNCONVD,PSNFD
- +2 SET PSNFD=$$GET1^DIQ(50.68,PSNTDRUG,109)
- +3 if PSNFD'=""
- WRITE " "_PSNFD
- +4 DO NOW^%DTC
- SET CPDATE=$PIECE(%,".")
- +5 SET PSSCP=$$CPTIER^PSNAPIS(PSNTDRUG,CPDATE,"",1)
- KILL CPDATE,X
- +6 IF $PIECE(PSSCP,"^")'=""
- WRITE " Tier ",$PIECE(PSSCP,"^")
- +7 ;inactive date
- SET PSNINACT=$$GET1^DIQ(50.68,PSNTDRUG,21,"I")
- +8 if $GET(PSNINACT)
- SET PSNCONVD=$$DATE^PSNLOOK(PSNINACT)
- +9 if $GET(PSNCONVD)'=""
- WRITE " "_PSNCONVD
- +10 QUIT
- +11 ;
- FD(PSNELFJ) ;DBIA #6754
- +1 NEW PSSFD
- +2 ;ppsn
- SET PSSFD=""
- SET PSSFD=$$GET1^DIQ(50.68,PSNELFJ,109)
- +3 if PSSFD'=""
- WRITE !,"Formulary Designator: "_PSSFD
- +4 QUIT
- +5 ;
- FDR(PSNELFJ) ;DBIA #6754
- +1 NEW PSNFD
- +2 ;ppsn
- SET PSNFD=""
- SET PSNFD=$$GET1^DIQ(50.68,PSNELFJ,109)
- +3 QUIT PSNFD
- +4 ;
- FDT(PSNELFJ) ;DBIA #6754
- +1 NEW PSNFDTXT
- SET PSNFDTXT=0
- if '$ORDER(^PSNDF(50.68,PSNELFJ,5.1,PSNFDTXT))
- QUIT
- +2 NEW X,DIWL,DIWR,DIWF,PSNJ,PSNDND,FDTCNT,FDTCNT2,PSNTEXT
- +3 KILL ^UTILITY($JOB,"W")
- +4 SET (PSNDND,PSNJ)=0
- SET PSNTEXT=""
- +5 FOR
- SET PSNJ=$ORDER(^PSNDF(50.68,PSNELFJ,5.1,PSNJ))
- if PSNJ=""
- QUIT
- Begin DoDot:1
- +6 SET PSNDND=$GET(^PSNDF(50.68,PSNELFJ,5.1,PSNJ,0))
- IF $TRANSLATE(PSNDND," ")'=""
- SET PSNTEXT=1
- End DoDot:1
- +7 if 'PSNTEXT
- QUIT
- +8 SET DIWL=15
- SET DIWR=79
- SET (PSNDND,PSNJ)=0
- SET FDTCNT2=1
- +9 FOR
- SET PSNJ=$ORDER(^PSNDF(50.68,PSNELFJ,5.1,PSNJ))
- if PSNJ=""
- QUIT
- Begin DoDot:1
- +10 SET PSNDND=$GET(^PSNDF(50.68,PSNELFJ,5.1,PSNJ,0))
- +11 SET X=PSNDND
- DO ^DIWP
- End DoDot:1
- +12 ;
- +13 SET FDTCNT=0
- FOR FDTCNT=0:0
- SET FDTCNT=$ORDER(^UTILITY($JOB,"W",DIWL,FDTCNT))
- if 'FDTCNT
- QUIT
- Begin DoDot:1
- +14 IF FDTCNT2=1
- WRITE !,"Product Text: "
- +15 IF FDTCNT2>1
- WRITE !," "
- +16 WRITE $GET(^UTILITY($JOB,"W",DIWL,FDTCNT,0))
- SET FDTCNT2=2
- End DoDot:1
- +17 KILL ^UTILITY($JOB,"W")
- +18 QUIT
- +19 ;