Changeset 623 for WorldVistAEHR/trunk/r/NATIONAL_DRUG_FILE-PSN/PSNACT.m
- Timestamp:
- Dec 4, 2009, 12:11:15 AM (14 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
WorldVistAEHR/trunk/r/NATIONAL_DRUG_FILE-PSN/PSNACT.m
r613 r623 1 PSNACT 2 ;;4.0; NATIONAL DRUG FILE;**22,35,47,62,65,70,160**; 30 Oct 98;Build 3 3 4 5 6 7 8 9 10 TEXT 11 12 ASKIT 13 14 15 16 17 ENTER 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 NDC 33 34 35 36 37 LKNDC 38 39 40 41 42 END 43 44 45 PRODI 46 47 48 49 NDCI 50 51 52 53 54 LINK 55 56 57 58 59 60 61 62 63 64 65 66 67 68 LISTNDC 69 70 71 72 PRT 73 74 75 LISTNDC1 76 77 78 79 80 81 82 83 84 85 86 87 88 89 ENTER1 90 91 92 93 94 95 96 97 98 99 .I $G(^PSNDF(50.68,ZA,8)) W !,"Exclude Drg-Drg Interaction Ck: Yes (No check for Drug-Drug Interactions)"100 101 CMOP 102 103 HANG 104 105 PRNT 106 107 108 109 110 111 PAD 112 113 114 115 PAD1 116 117 DT(Y) 118 119 120 GCN 121 122 123 124 125 1 PSNACT ;BIR/DMA&WRT-inquiries by VAPN, CMOP ID, or NDC ; 07/02/03 14:01 2 ;;4.0; NATIONAL DRUG FILE;**22,35,47,62,65,70**; 30 Oct 98 3 ; 4 ;Reference to ^PS(50.606 supported by DBIA #2174 5 ; 6 I '$D(IORVON) S X="IORVON;IORVOFF" D ENDR^%ZISS 7 K DIC,DIR F ZXX=0:0 W ! D TEXT,ASKIT Q:$D(DIRUT) 8 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,PMIS,QQQ,ENG,MAP 9 Q 10 TEXT W !,"This option allows you to lookup NDF file information three ways (VA Product",!,"Name, NDC, or CMOP ID number).",! 11 Q 12 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) 13 I ASK="NDC" D NDC 14 I ASK="VA PRODUCT" D LISTNDC 15 I ASK="CMOP ID" D CMOP 16 Q 17 ENTER K QQQ S DA=+Y,Y1=^PSNDF(50.68,DA,1),Y3=^(3),Y7=$G(^(7)),Y5=$G(^(5)),Y6=$G(^PSNDF(50.68,DA,6,1,0)),QQQ=$P(Y1,"^",5) D GCN D 18 .W @IOF,!,"VA Product Name: ",$P(Y(0),"^"),$$DT($P(Y7,"^",3)) 19 .W !,"VA Generic Name: ",$P(^PSNDF(50.6,+$P(Y(0),"^",2),0),"^"),!,"Dose Form: ",$P(^PS(50.606,+$P(Y(0),"^",3),0),"^")," Strength: ",$P(Y(0),"^",4)," Units: ",$P($G(^PS(50.607,+$P(Y(0),"^",5),0)),"^") 20 .W !,"National Formulary Name: ",$P(Y(0),"^",6),!,"VA Print Name: ",$P(Y1,"^"),!,"VA Product Identifier: ",$P(Y1,"^",2)," Transmit to CMOP: ",$S($P(Y1,"^",3):"Yes",1:"No") 21 .W " VA Dispense Unit: ",$P($G(^PSNDF(50.64,+$P(Y1,"^",4),0)),"^") 22 .W !,"PMIS: ",PMIS,!,"Active Ingredients: " S K=0 F S K=$O(^PSNDF(50.68,DA,2,K)) Q:'K!($G(QUIT)) S X=^(K,0),ING=^PS(50.416,K,0) S:$P(ING,"^",2) ING=^PS(50.416,$P(ING,"^",2),0) D 23 ..D:($Y+5)>IOSL&('$G(QUIT)) HANG Q:$G(QUIT) W ?23,$P(ING,"^")," Strength: ",$P(X,"^",2)," Units :",$P($G(^PS(50.607,+$P(X,"^",3),0)),"^"),! 24 .Q:$G(QUIT) W !,"Primary VA Drug Class: ",$P($G(^PS(50.605,+Y3,0),"Unknown"),"^"),!,"Secondary VA Drug Class: " S K=0 F S K=$O(^PSNDF(50.68,DA,4,K)) Q:'K W ?26,$P($G(^PS(50.605,+K,0),"Unknown"),"^"),! 25 .W !,"CS Federal Schedule: "_$S($P($G(^PSNDF(50.68,DA,7)),"^")]"":$P(^PSNDF(50.68,DA,7),"^"),1:"") 26 .W !,"National Formulary Indicator: " W:$P(Y5,"^")=1 "Yes" W:$P(Y5,"^")=0 "No" 27 .W !,"National Formulary Restriction: ",!,$P(Y6,"^") 28 .I $G(^PSNDF(50.68,DA,8)) W !,"Exclude Drg-Drg Interaction Ck: Yes (No check for Drug-Drug Interactions)" 29 Q 30 K DA,DIE,DIE,DIRUT,DR,ING,K,OLDDA,X,Y,Y1,Y3,Y7 Q 31 ; 32 NDC ;OR UPN 33 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) 34 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 D IX^DIC Q:Y<0 S DA=+Y,NDF=Y(0) D LKNDC 35 I PROMPT="UPN" S DIC=50.67,DIC(0)="AEQZN",DIC("A")="Select "_PROMPT_":"_" ",D=PROMPT D IX^DIC Q:Y<0 S DA=+Y,NDF=Y(0) D LKNDC 36 Q 37 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: " 38 S K=0 F S K=$O(^PSNDF(50.67,DA,1,K)) Q:'K W $P(^(K,0),"^")," " 39 W !,"Package Size: ",$P(^PS(50.609,$P(NDF,"^",8),0),"^")," Package Type: ",$P(^PS(50.608,$P(NDF,"^",9),0),"^") 40 S ZA=$P(NDF,"^",6) D ENTER1 41 Q 42 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 43 Q 44 ; 45 PRODI ;INQUIRE INTO 50.68 46 F S DIC="^PSNDF(50.68,",DIC(0)="AEQM" D ^DIC Q:Y<0 S DA=+Y D EN^DIQ 47 K DA,DIC,X,Y Q 48 ; 49 NDCI ;INQUIRE INTO 50.67 50 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" 51 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 52 K DA,DIC,DIR,PROMPT,X,Y Q 53 ; 54 LINK ;LINK NDCS OR UPNS 55 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) 56 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 57 .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 58 .I PROMPT="NDC" D 59 ..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 60 ..I IN S DA(1)=DA,DA=IN,DIE="^PSNDF(50.67,"_DA(1)_",2,",DR=".01///@;" D ^DIE W !,"Unlinked",! Q 61 ..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 62 .I PROMPT="UPN" D 63 ..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 64 ..S DA(1)=DA,DA=IN,DIE="^PSNDF(50.67,"_DA(1)_",3,",DR=".01///@;" D ^DIE W !,"Unlinked",! Q 65 ..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 66 G LINK 67 ; 68 LISTNDC ;LOOK UP NDCS BY PRODUCT 69 K L,DA,^TMP($J),DIC 70 S DIC=50.68,DIC(0)="AQEMZ" D ^DIC G END:Y<0 S IEN=+Y D ENTER 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)="" 71 Q 72 PRT D:($Y+5)>IOSL&('$G(QUIT)) HANG Q:$G(QUIT) S DA=SIE,DIC="^PSNDF(50.67," W ! D EN^DIQ 73 Q 74 ; 75 LISTNDC1 ;LOOK UP PARTIAL NDC 76 ; 77 F K ^TMP($J) S QUIT=0,DIR(0)="F^1:12",DIR("A")="Select NDC " D ^DIR Q:$D(DIRUT) S PSN1=Y,PSN=Y D 78 .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 79 .Q:QUIT 80 .I PSN1?."0".E S PSN1=PSN1_"/" 81 .I PSN1?.N,PSN1=+PSN1 S PSN1=$$LJ^XLFSTR(PSN1,12,0)-1 82 .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 83 ..S MORE=$E($O(^PSNDF(50.67,"NDC",PSN1)),1,$L(PSN))=PSN!$O(^(PSN1,DA)) I ZCT#5&MORE Q 84 ..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 " 85 ..D ^DIR I $D(DUOUT)!$D(DTOUT) S QUIT=1 Q 86 ..I Y="" Q 87 ..S DA=^TMP($J,Y),QUIT=1,DIC="^PSNDF(50.67," W !! D EN^DIQ Q 88 G END 89 ENTER1 K QQQ S Z0=^PSNDF(50.68,ZA,0),Z1=^PSNDF(50.68,ZA,1),Z3=^PSNDF(50.68,ZA,3),Z7=$G(^PSNDF(50.68,ZA,7)),Z5=$G(^PSNDF(50.68,ZA,5)),Z6=$G(^PSNDF(50.68,ZA,6,1,0)),QQQ=$P(Z1,"^",5) D GCN D 90 .W !,"VA Product Name: ",$P(Z0,"^"),!,"VA Generic Name: ",$P(^PSNDF(50.6,+$P(Z0,"^",2),0),"^"),!,"Dose Form: ",$P(^PS(50.606,+$P(Z0,"^",3),0),"^")," Strength: ",$P(Z0,"^",4)," Units: ",$P($G(^PS(50.607,+$P(Z0,"^",5),0)),"^") 91 .W !,"National Formulary Name: ",$P(Z0,"^",6),!,"VA Print Name: ",$P(Z1,"^"),!,"VA Product Identifier: ",$P(Z1,"^",2)," Transmit to CMOP: ",$S($P(Z1,"^",3):"Yes",1:"No") 92 .W " VA Dispense Unit: ",$P($G(^PSNDF(50.64,+$P(Z1,"^",4),0)),"^") 93 .W !,"PMIS: ",PMIS,!,"Active Ingredients: " S K=0 F S K=$O(^PSNDF(50.68,ZA,2,K)) Q:'K!($G(QUIT)) S X=^(K,0),ING=^PS(50.416,K,0) S:$P(ING,"^",2) ING=^PS(50.416,$P(ING,"^",2),0) D 94 ..D:($Y+5)>IOSL&('$G(QUIT)) HANG Q:$G(QUIT) W ?23,$P(ING,"^")," Strength: ",$P(X,"^",2)," Units :",$P($G(^PS(50.607,+$P(X,"^",3),0)),"^"),! 95 .Q:$G(QUIT) W !,"Primary VA Drug Class: ",$P($G(^PS(50.605,+Z3,0),"Unknown"),"^"),!,"Secondary VA Drug Class: " S K=0 F S K=$O(^PSNDF(50.68,ZA,4,K)) Q:'K W ?26,$P($G(^PS(50.605,+K,0),"Unknown"),"^"),! 96 .W !,"CS Federal Schedule: "_$S($P(Z7,"^")]"":$P(Z7,"^"),1:"") 97 .W !,"National Formulary Indicator: " W:$P(Z5,"^")=1 "Yes" W:$P(Z5,"^")=0 "No" 98 .W !,"National Formulary Restriction: ",!,$P(Z6,"^") 99 .I $G(^PSNDF(50.68,DA,8)) W !,"Exclude Drg-Drg Interaction Ck: Yes (No check for Drug-Drug Interactions)" 100 Q 101 CMOP K DIC S DIC="^PSNDF(50.68,",DIC(0)="QEAZ",D="C",DIC("A")="CMOP ID: " D MIX^DIC1 Q:Y<0 S IEN=+Y D ENTER F SIE=0:0 S SIE=$O(^PSNDF(50.68,"ANDC",IEN,SIE)) Q:'SIE D PRNT 102 Q 103 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 104 Q 105 PRNT D:($Y+5)>IOSL&('$G(QUIT)) HANG Q:$G(QUIT) 106 S NDX=^PSNDF(50.67,SIE,0) 107 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: " 108 S SIE1=0 F S SIE1=$O(^PSNDF(50.67,SIE,1,SIE1)) Q:'SIE1 W $P(^(SIE1,0),"^") 109 W !,"Package Size: ",$P(^PS(50.609,$P(NDX,"^",8),0),"^")," Package Type: ",$P(^PS(50.608,$P(NDX,"^",9),0),"^") 110 Q 111 PAD S ANS=Y F VV=1:1:3 S VV1=$S(VV=1:6,VV=2:4,VV=3:2) D PAD1 112 S ANS=$P(ANS,"-",1)_$P(ANS,"-",2)_$P(ANS,"-",3) K VV,VV1 113 S ANS=$TR(ANS,"-"),X=ANS 114 Q 115 PAD1 I $L($P(ANS,"-",VV))<VV1 S $P(ANS,"-",VV)=$E("0000000",1,VV1-$L($P(ANS,"-",VV)))_$P(ANS,"-",VV) 116 Q 117 DT(Y) ;Inactivation Date display 118 X:Y ^DD("DD") Q $S(Y]"":IORVON_" ***INACTIVE: "_Y_" ***"_IORVOFF,1:"") 119 Q 120 GCN I QQQ']"" S PMIS="None" 121 I QQQ]"",'$D(^PS(50.623,"B",QQQ)) S PMIS="None" 122 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),"^") 123 Q 124 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),"^") 125 Q
Note:
See TracChangeset
for help on using the changeset viewer.