Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: PSNACT

PSNACT.m

Go to the documentation of this file.
  1. 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
  1. ;
  1. ;Reference to ^PS(50.606 supported by DBIA #2174
  1. ;Reference to ^PSNAPIS supported by DBIA #2531
  1. ;
  1. I '$D(IORVON) S X="IORVON;IORVOFF" D ENDR^%ZISS
  1. K DIC,DIR F ZXX=0:0 W ! D TEXT,ASKIT Q:$D(DIRUT)
  1. 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
  1. N PMIS,QQQ,ENG,MAP,D,ANS,ZCT,DYAYGO,DUOUT,DTOUT,PSNTIER
  1. Q
  1. TEXT W !,"This option allows you to lookup NDF file information three ways (VA Product",!,"Name, NDC, or CMOP ID number).",!
  1. Q
  1. 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)
  1. I ASK="NDC" D NDC
  1. I ASK="VA PRODUCT" D LISTNDC
  1. I ASK="CMOP ID" D CMOP
  1. Q
  1. ;
  1. NDC ;OR UPN
  1. 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)
  1. 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
  1. 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
  1. Q
  1. 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: "
  1. S K=0 F S K=$O(^PSNDF(50.67,DA,1,K)) Q:'K W $P(^(K,0),"^")," "
  1. W !,"Package Size: ",$P(^PS(50.609,$P(NDF,"^",8),0),"^")," Package Type: ",$P(^PS(50.608,$P(NDF,"^",9),0),"^")
  1. S ZA=$P(NDF,"^",6) D PRINT(ZA)
  1. Q
  1. 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
  1. ;
  1. PRODI ;INQUIRE INTO 50.68
  1. F S DIC="^PSNDF(50.68,",DIC(0)="AEQM" D ^DIC Q:Y<0 S DA=+Y D EN^DIQ
  1. K DA,DIC,X,Y Q
  1. ;
  1. NDCI ;INQUIRE INTO 50.67
  1. 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"
  1. 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
  1. K DA,DIC,DIR,PROMPT,X,Y Q
  1. ;
  1. 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)
  1. 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
  1. .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
  1. .I PROMPT="NDC" D
  1. ..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
  1. ..I IN S DA(1)=DA,DA=IN,DIE="^PSNDF(50.67,"_DA(1)_",2,",DR=".01///@;" D ^DIE W !,"Unlinked",! Q
  1. ..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
  1. .I PROMPT="UPN" D
  1. ..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
  1. ..S DA(1)=DA,DA=IN,DIE="^PSNDF(50.67,"_DA(1)_",3,",DR=".01///@;" D ^DIE W !,"Unlinked",! Q
  1. ..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
  1. G LINK
  1. ;
  1. LISTNDC ;LOOK UP NDCS BY PRODUCT
  1. K L,DA,^TMP($J),DIC
  1. S DIC=50.68,DIC(0)="AQEMZ",DIC("W")="S PSNTDRUG=Y D GETTIER^PSNACT(PSNTDRUG)" D ^DIC G END:Y<0
  1. 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)=""
  1. Q
  1. PRT D:($Y+5)>IOSL&('$G(QUIT)) HANG Q:$G(QUIT) S DA=SIE,DIC="^PSNDF(50.67," W ! D EN^DIQ
  1. Q
  1. ;
  1. LISTNDC1 ;LOOK UP PARTIAL NDC
  1. ;
  1. 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
  1. .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
  1. .Q:QUIT
  1. .I PSN1?."0".E S PSN1=PSN1_"/"
  1. .I PSN1?.N,PSN1=+PSN1 S PSN1=$$LJ^XLFSTR(PSN1,12,0)-1
  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
  1. ..S MORE=$E($O(^PSNDF(50.67,"NDC",PSN1)),1,$L(PSN))=PSN!$O(^(PSN1,DA)) I ZCT#5&MORE Q
  1. ..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 "
  1. ..D ^DIR I $D(DUOUT)!$D(DTOUT) S QUIT=1 Q
  1. ..I Y="" Q
  1. ..S DA=^TMP($J,Y),QUIT=1,DIC="^PSNDF(50.67," W !! D EN^DIQ Q
  1. G END
  1. ;
  1. PRINT(VAPRDIEN) ; Prints the Va Product field
  1. ;Input: VAPRDIEN - Internal Entry Number (IEN) in the VA PRODUCT (#50.68) file
  1. ;
  1. N QQQ,PSNELIEN,Z0,Z1,Z3,Z5,Z6,Z7,X,PSNELXY,K,ING
  1. S Z0=^PSNDF(50.68,VAPRDIEN,0)
  1. S Z1=^PSNDF(50.68,VAPRDIEN,1)
  1. S Z3=^PSNDF(50.68,VAPRDIEN,3)
  1. S Z5=$G(^PSNDF(50.68,VAPRDIEN,5))
  1. S Z6=$G(^PSNDF(50.68,VAPRDIEN,6,1,0))
  1. S Z7=$G(^PSNDF(50.68,VAPRDIEN,7))
  1. S QQQ=$P(Z1,"^",5) D GCN
  1. W !,"VA Product Name: ",$P(Z0,"^"),$$DT($P(Z7,"^",3))
  1. W !,"VA Generic Name: ",$P(^PSNDF(50.6,+$P(Z0,"^",2),0),"^")
  1. D NDOSE(VAPRDIEN)
  1. W !,"National Formulary Name: ",$P(Z0,"^",6)
  1. W !,"VA Print Name: ",$P(Z1,"^")
  1. 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)),"^")
  1. W !,"PMIS: ",PMIS,!,"Active Ingredients: "
  1. S (K,QUIT)=0 F S K=$O(^PSNDF(50.68,VAPRDIEN,2,K)) Q:'K D Q:$G(QUIT)
  1. . S (PSNELXY,X)=^PSNDF(50.68,VAPRDIEN,2,K,0),ING=^PS(50.416,K,0)
  1. . S:$P(ING,"^",2) ING=^PS(50.416,$P(ING,"^",2),0)
  1. . W ?23,$P(ING,"^")," Strength: ",$P(PSNELXY,"^",2)," Units: ",$P($G(^PS(50.607,+$P(PSNELXY,"^",3),0)),"^")
  1. . D:($Y+5)>IOSL&'QUIT HANG Q:$G(QUIT) W !
  1. Q:$G(QUIT)
  1. W !,"Primary VA Drug Class: ",$P($G(^PS(50.605,+Z3,0),"Unknown"),"^")
  1. W !,"Secondary VA Drug Class: "
  1. S (K,QUIT)=0 F S K=$O(^PSNDF(50.68,VAPRDIEN,4,K)) Q:'K D Q:$G(QUIT)
  1. . W ?26,$P($G(^PS(50.605,+K,0),"Unknown"),"^")
  1. . D:($Y+5)>IOSL&'QUIT HANG Q:$G(QUIT) W !
  1. Q:$G(QUIT)
  1. D:($Y+5)>IOSL HANG Q:$G(QUIT)
  1. W !,"CS Federal Schedule: "_$S($P($G(^PSNDF(50.68,VAPRDIEN,7)),"^")]"":$P(^PSNDF(50.68,VAPRDIEN,7),"^"),1:"") D EXPAN(VAPRDIEN)
  1. D:($Y+5)>IOSL HANG Q:$G(QUIT)
  1. W !,"National Formulary Indicator: ",$S($P(Z5,"^"):"Yes",1:"No")
  1. D:($Y+5)>IOSL HANG Q:$G(QUIT)
  1. D FD(VAPRDIEN) ;ppsn
  1. D:($Y+5)>IOSL HANG Q:$G(QUIT)
  1. W !,"National Formulary Restriction: ",! D NFIP(VAPRDIEN) Q:$G(QUIT)
  1. D:($Y+5)>IOSL HANG Q:$G(QUIT)
  1. D FDT(VAPRDIEN) Q:$G(QUIT) ;ppsn - formulary designator text
  1. D:($Y+5)>IOSL HANG Q:$G(QUIT)
  1. D CPTIER(VAPRDIEN) ; Copay Tier
  1. D:($Y+5)>IOSL HANG Q:$G(QUIT)
  1. I $G(^PSNDF(50.68,VAPRDIEN,8)) W !,"Exclude Drg-Drg Interaction Ck: Yes (No check for Drug-Drug Interactions)"
  1. D:($Y+5)>IOSL HANG Q:$G(QUIT)
  1. D OVEX(VAPRDIEN)
  1. D:($Y+5)>IOSL HANG Q:$G(QUIT)
  1. D CLEFF^PSNCLEHW(VAPRDIEN,$G(QUIT))
  1. D:($Y+5)>IOSL HANG Q:$G(QUIT)
  1. D POSDOS(VAPRDIEN)
  1. D:($Y+5)>IOSL HANG Q:$G(QUIT)
  1. W !,"Maximum Days Supply: ",$$GET1^DIQ(50.68,VAPRDIEN,32)
  1. D:($Y+5)>IOSL HANG Q:$G(QUIT)
  1. D HAZWASTE^PSNCLEHW(VAPRDIEN)
  1. D:($Y+5)>IOSL HANG Q:$G(QUIT)
  1. D CODSYS(VAPRDIEN)
  1. W ! D HANG
  1. Q
  1. ;
  1. 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
  1. Q
  1. 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
  1. Q
  1. PRNT D:($Y+5)>IOSL&('$G(QUIT)) HANG Q:$G(QUIT)
  1. S NDX=^PSNDF(50.67,SIE,0)
  1. 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: "
  1. S SIE1=0 F S SIE1=$O(^PSNDF(50.67,SIE,1,SIE1)) Q:'SIE1 W $P(^(SIE1,0),"^")
  1. W !,"Package Size: ",$P(^PS(50.609,$P(NDX,"^",8),0),"^")," Package Type: ",$P(^PS(50.608,$P(NDX,"^",9),0),"^")
  1. Q
  1. PAD S ANS=Y F VV=1:1:3 S VV1=$S(VV=1:6,VV=2:4,VV=3:2) D PAD1
  1. S ANS=$P(ANS,"-",1)_$P(ANS,"-",2)_$P(ANS,"-",3) K VV,VV1
  1. S ANS=$TR(ANS,"-"),X=ANS
  1. Q
  1. PAD1 I $L($P(ANS,"-",VV))<VV1 S $P(ANS,"-",VV)=$E("0000000",1,VV1-$L($P(ANS,"-",VV)))_$P(ANS,"-",VV)
  1. Q
  1. DT(Y) ;Inactivation Date display
  1. X:Y ^DD("DD") Q $S(Y]"":IORVON_" ***INACTIVE: "_Y_" ***"_IORVOFF,1:"")
  1. Q
  1. GCN I QQQ']"" S PMIS="None"
  1. I QQQ]"",'$D(^PS(50.623,"B",QQQ)) S PMIS="None"
  1. 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),"^")
  1. Q
  1. 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),"^")
  1. Q
  1. ;
  1. NDOSE(PSNELXXX) ;New Dose Form/Strength/Unit display added with patch PSN*4*169
  1. N PSNELSTL,PSNELUNL,PSNELZER
  1. S PSNELZER=$G(^PSNDF(50.68,PSNELXXX,0))
  1. I '$P(PSNELZER,"^",3) W !,"Dose Form: "
  1. 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:"")
  1. S PSNELSTL=$L($P(PSNELZER,"^",4))
  1. I $P(PSNELZER,"^",5) S PSNELUNL=$L($P($G(^PS(50.607,+$P(PSNELZER,"^",5),0)),"^"))
  1. I '$P(PSNELZER,"^",5) S PSNELUNL=0
  1. 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
  1. W !,"Strength: ",$P(PSNELZER,"^",4)
  1. W !,"Units: " I PSNELUNL<72 W $S($P(PSNELZER,"^",5):$P($G(^PS(50.607,+$P(PSNELZER,"^",5),0)),"^"),1:"") Q
  1. W !," "_$P($G(^PS(50.607,+$P(PSNELZER,"^",5),0)),"^")
  1. Q
  1. ;
  1. OVEX(PSNELORX) ;New Override Dose Form display added with patch PSN*4*169
  1. N PSNELDFF
  1. 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
  1. .S PSNELDFF=$P($G(^PSNDF(50.68,PSNELORX,0)),"^",3)
  1. .I 'PSNELDFF Q
  1. .I '$D(^PS(50.606,PSNELDFF,0)) Q
  1. .I $P($G(^PS(50.606,PSNELDFF,1)),"^")=1 W " (Dosage Checks shall be performed)" Q
  1. .I $P($G(^PS(50.606,PSNELDFF,1)),"^")=0 W " (No dosage checks performed)"
  1. Q
  1. CPTIER(VAPRD) ;
  1. ; Input: VAPRD - VA PRODUCT (#50.68) entry IEN
  1. N CPDATE,X D NOW^%DTC S CPDATE=X S PSNTIER=$$CPTIER^PSNAPIS(VAPRD,CPDATE,"",1) K CPDATE,X
  1. ; PSNTIER = Copay Tier^Effective Date^End Date
  1. W !,"Copay Tier: ",$P(PSNTIER,"^",1)
  1. W !,"Copay Effective Date: " S Y=$P(PSNTIER,"^",2) D DD^%DT W Y K Y
  1. W !
  1. Q
  1. EXPAN(PSNELFZA) ;
  1. N PSNELFZB,PSNELFZC
  1. I $P($G(^PSNDF(50.68,PSNELFZA,7)),"^")="" Q
  1. S PSNELFZB=PSNELFZA_"," S PSNELFZC=$$GET1^DIQ(50.68,PSNELFZB,19)
  1. W " "_$G(PSNELFZC)
  1. Q
  1. NFIP(PSNELFJ) ;
  1. N PSNELFJZ,PSNELFJC
  1. S PSNELFJC=0
  1. F PSNELFJZ=0:0 S PSNELFJZ=$O(^PSNDF(50.68,PSNELFJ,6,PSNELFJZ)) Q:'PSNELFJZ!($G(QUIT)) D
  1. .I PSNELFJC W !
  1. .W $G(^PSNDF(50.68,PSNELFJ,6,PSNELFJZ,0))
  1. .S PSNELFJC=1
  1. .D:($Y+5)>IOSL HANG
  1. I '$G(QUIT),$G(PSNELFJC) W !
  1. Q
  1. ;
  1. POSDOS(VAPRD) ; Dispaly Possible Dosage Auto-Create Setting fields
  1. ; Input: VAPRD - VA PRODUCT (#50.68) entry IEN
  1. ;
  1. N POSDOS Q:'$G(VAPRD)
  1. S POSDOS=$$POSDOS^PSNAPIS(VAPRD)
  1. W !!,"Auto-Create Default Possible Dosage? ",$S($P(POSDOS,"^")="Y":"Yes",1:"No")
  1. I $P(POSDOS,"^")="N" D
  1. . 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:"")
  1. . I ($P(POSDOS,"^",2)'="N") D
  1. . . W !," Package: ",$S($P(POSDOS,"^",3)="O":"Outpatient",$P(POSDOS,"^",3)="I":"Inpatient",$P(POSDOS,"^",3)="IO":"Both Inpatient and Outpatient",1:"")
  1. Q
  1. ;
  1. CODSYS(PSNCIEN) ;CODING SYSTEM
  1. N I,J,PSNCODX,PSNCODJ,PSNRXCUI S PSNCODX=0
  1. F I=1:1 S PSNCODX=$O(^PSNDF(50.68,PSNCIEN,11,PSNCODX)) Q:PSNCODX="B"!(PSNCODX="") D
  1. . S PSNRXCUI=$G(^PSNDF(50.68,PSNCIEN,11,PSNCODX,0)) Q:PSNRXCUI'="RxNorm"
  1. . W !!,"Coding System: ",$P(^PSNDF(50.68,PSNCIEN,11,PSNCODX,0),"^",1) S PSNCODJ=0
  1. . F J=1:1 S PSNCODJ=$O(^PSNDF(50.68,PSNCIEN,11,PSNCODX,1,PSNCODJ)) Q:PSNCODJ="B"!(PSNCODJ="") D
  1. .. W !,"Code: ",$P(^PSNDF(50.68,PSNCIEN,11,PSNCODX,1,PSNCODJ,0),"^",1)
  1. W !
  1. Q
  1. ;
  1. GETTIERN(PSNCTNDC) ;Get copay tier by NDC; called by DIC to get copay tier for today's date
  1. N CPDATE,X,PSSCP,VAPID,VAPNAM,PSNINACT,PSNCONVD,PSNFD
  1. D NOW^%DTC S CPDATE=$P(%,".")
  1. S VAPID=$$GET1^DIQ(50.67,PSNCTNDC,5,"I")
  1. I PROMPT="UPN"!(PROMPT="NDC") S VAPNAM=$$GET1^DIQ(50.68,VAPID,.01) W " ",VAPNAM
  1. S PSNFD=$$GET1^DIQ(50.68,VAPID,109)
  1. W:PSNFD'="" " "_PSNFD
  1. S PSSCP=$$CPTIER^PSNAPIS(VAPID,CPDATE) K CPDATE,X
  1. I $P(PSSCP,"^")'="" W " Tier ",$P(PSSCP,"^")
  1. S PSNINACT=$$GET1^DIQ(50.67,PSNCTNDC,7,"I") ;inactive date
  1. S:$G(PSNINACT) PSNCONVD=$$DATE^PSNLOOK(PSNINACT)
  1. W:$G(PSNCONVD)'="" " "_PSNCONVD
  1. Q
  1. ;
  1. GETTIER(PSNTDRUG) ;called by DIC; look up copay tier by va product for the current date
  1. N CPDATE,X,PSSCP,PSNINACT,PSNCONVD,PSNFD
  1. S PSNFD=$$GET1^DIQ(50.68,PSNTDRUG,109)
  1. W:PSNFD'="" " "_PSNFD
  1. D NOW^%DTC S CPDATE=$P(%,".")
  1. S PSSCP=$$CPTIER^PSNAPIS(PSNTDRUG,CPDATE,"",1) K CPDATE,X
  1. I $P(PSSCP,"^")'="" W " Tier ",$P(PSSCP,"^")
  1. S PSNINACT=$$GET1^DIQ(50.68,PSNTDRUG,21,"I") ;inactive date
  1. S:$G(PSNINACT) PSNCONVD=$$DATE^PSNLOOK(PSNINACT)
  1. W:$G(PSNCONVD)'="" " "_PSNCONVD
  1. Q
  1. ;
  1. FD(PSNELFJ) ;DBIA #6754
  1. N PSSFD
  1. S PSSFD="",PSSFD=$$GET1^DIQ(50.68,PSNELFJ,109) ;ppsn
  1. W:PSSFD'="" !,"Formulary Designator: "_PSSFD
  1. Q
  1. ;
  1. FDR(PSNELFJ) ;DBIA #6754
  1. N PSNFD
  1. S PSNFD="",PSNFD=$$GET1^DIQ(50.68,PSNELFJ,109) ;ppsn
  1. Q PSNFD
  1. ;
  1. FDT(PSNELFJ) ;DBIA #6754
  1. N PSNFDTXT S PSNFDTXT=0 Q:'$O(^PSNDF(50.68,PSNELFJ,5.1,PSNFDTXT))
  1. N X,DIWL,DIWR,DIWF,PSNJ,PSNDND,FDTCNT,FDTCNT2,PSNTEXT
  1. K ^UTILITY($J,"W")
  1. S (PSNDND,PSNJ)=0,PSNTEXT=""
  1. F S PSNJ=$O(^PSNDF(50.68,PSNELFJ,5.1,PSNJ)) Q:PSNJ="" D
  1. .S PSNDND=$G(^PSNDF(50.68,PSNELFJ,5.1,PSNJ,0)) I $TR(PSNDND," ")'="" S PSNTEXT=1
  1. Q:'PSNTEXT
  1. S DIWL=15,DIWR=79,(PSNDND,PSNJ)=0,FDTCNT2=1
  1. F S PSNJ=$O(^PSNDF(50.68,PSNELFJ,5.1,PSNJ)) Q:PSNJ="" D
  1. .S PSNDND=$G(^PSNDF(50.68,PSNELFJ,5.1,PSNJ,0))
  1. .S X=PSNDND D ^DIWP
  1. ;
  1. S FDTCNT=0 F FDTCNT=0:0 S FDTCNT=$O(^UTILITY($J,"W",DIWL,FDTCNT)) Q:'FDTCNT D
  1. .I FDTCNT2=1 W !,"Product Text: "
  1. .I FDTCNT2>1 W !," "
  1. .W $G(^UTILITY($J,"W",DIWL,FDTCNT,0)) S FDTCNT2=2
  1. K ^UTILITY($J,"W")
  1. Q
  1. ;