Ignore:
Timestamp:
Dec 4, 2009, 12:11:15 AM (16 years ago)
Author:
George Lilly
Message:

revised back to 6/30/08 version

Location:
WorldVistAEHR/trunk/r/NATIONAL_DRUG_FILE-PSN
Files:
2 edited

Legend:

Unmodified
Added
Removed

  • WorldVistAEHR/trunk/r/NATIONAL_DRUG_FILE-PSN/PSNACT.m

    r613 r623  
    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,160**; 30 Oct 98;Build 3
    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,ZA,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
     1PSNACT ;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
     10TEXT W !,"This option allows you to lookup NDF file information three ways (VA Product",!,"Name, NDC, or CMOP ID number).",!
     11 Q
     12ASKIT 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
     17ENTER 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 ;
     32NDC ;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
     37LKNDC 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
     42END 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 ;
     45PRODI ;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 ;
     49NDCI ;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 ;
     54LINK ;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 ;
     68LISTNDC ;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
     72PRT D:($Y+5)>IOSL&('$G(QUIT)) HANG Q:$G(QUIT)  S DA=SIE,DIC="^PSNDF(50.67," W ! D EN^DIQ
     73 Q
     74 ;
     75LISTNDC1 ;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
     89ENTER1 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
     101CMOP 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
     103HANG 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
     105PRNT 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
     111PAD 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
     115PAD1 I $L($P(ANS,"-",VV))<VV1 S $P(ANS,"-",VV)=$E("0000000",1,VV1-$L($P(ANS,"-",VV)))_$P(ANS,"-",VV)
     116 Q
     117DT(Y) ;Inactivation Date display
     118 X:Y ^DD("DD") Q $S(Y]"":IORVON_" ***INACTIVE: "_Y_" ***"_IORVOFF,1:"")
     119 Q
     120GCN 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

  • WorldVistAEHR/trunk/r/NATIONAL_DRUG_FILE-PSN/PSNHFRM.m

    r613 r623  
    1 PSNHFRM ;BIR/WRT-Report of Hospital Formulary drugs from DRUG file ; 8/28/07 12:07pm
    2         ;;4.0; NATIONAL DRUG FILE;**152,160**;30 Oct 98;Build 3
    3 DVC     K IO("Q"),%ZIS,POP,IOP S %ZIS="QM",%ZIS("B")="",%ZIS("A")="DEVICE: " D ^%ZIS G:POP DONE W:$E(IOST)'="P" !!,"This report must be run on a printer.",!! G:$E(IOST)'="P" DVC I POP K IOP,POP,IO("Q") Q
    4 QUEUE   I $D(IO("Q")) K IO("Q") S ZTRTN="ENQ^PSNHFRM" K ZTSAVE,ZTDTH,ZTSK S PSNDEV=ION_";"_IOST_";"_$S($D(IO("DOC")):IO("DOC"),1:IOM)_";"_IOSL,ZTSAVE("SF")="",ZTSAVE("PSNDEV")="",ZTSAVE("PSNANS")="",ZTDESC="Hospital Formulary Report",ZTIO=""
    5         I  D ^%ZTLOAD K MJT,%ZIS,POP,IOP,ZTSK D ^%ZISC Q
    6 ENQ     ;ENTRY POINT WHEN QUEUED
    7         D LOOP
    8         I $D(ZTQUEUED) D QUEUE1
    9         U IO
    10 ENQ1    S PSNPGCT=0,PSNPGLNG=IOSL-6
    11         D TITLE,LOOP1 W @IOF G DONE
    12 TITLE   I $D(IOF),IOF]"" W @IOF S PSNPGCT=PSNPGCT+1
    13         W !,PSNANS
    14         S X="T" D ^%DT X ^DD("DD") W ?55,"Date printed: ",Y,!?55,"Page: ",PSNPGCT,!!
    15         W !,"GENERIC/TRADE NAME"
    16         W !,?3,"GENERIC/TRADE NAME",?46,"CLASS",?59,"PRICE / DISP UNT",!
    17         F MJT=1:1:80 W "-"
    18         Q
    19 DONE    S:$D(ZTQUEUED) ZTREQ="@" K ^TMP($J),PSNB,PSNFLG,PSNAME,PSNCL,PSNCLSS,PSNAR,PSNFF,PSNFG,PSNGG,PSNPR,PSNLGN,PSNPGCT,PSNPGLNG,ZTRTN,Y,PSNDEV,MJT,PSNLOC,PSNKK,PSNPRIC,PSNPRICE
    20         K PSNANS,SF,DU,PSNANSR,PSNTRD,PSNUM,PSNDATE,X,IOP,POP,IO("Q") W:$Y @IOF D ^%ZISC
    21         Q
    22 QUEUE1  S IOP=PSNDEV F  D ^%ZIS Q:'POP  H 20
    23         Q
    24 LOOP    F PSNB=0:0 S PSNB=$O(^PSDRUG(PSNB)) Q:'PSNB  D
    25         .Q:'$D(^PSDRUG(PSNB,0))
    26         .S PSNAME=$P(^PSDRUG(PSNB,0),"^",1) Q:PSNAME=""
    27         .S PSNCLSS=$P(^PSDRUG(PSNB,0),"^",2) S:PSNCLSS']"" PSNCLSS="No Class" I $P(^PSDRUG(PSNB,0),"^",9)'=1 D CHECK
    28         Q
    29 GETDATE I '$D(^PSDRUG(PSNB,"I")) D GETNODE,GETPRIC
    30         I $D(^PSDRUG(PSNB,"I")) S PSNDATE=$P(^PSDRUG(PSNB,"I"),"^") D NOW^%DTC I X<PSNDATE D GETNODE,GETPRIC
    31         Q
    32 GETNODE K X I '$D(^PSDRUG(PSNB,660)) S PSNPRICE="No Price /" D GETRADE,GETRADE1
    33         Q
    34 GETPRIC I $D(^PSDRUG(PSNB,660)) S PSNPRIC=$P(^PSDRUG(PSNB,660),"^",6),DU=$P(^PSDRUG(PSNB,660),"^",8) D PRICE1,PRICE2
    35         Q
    36 PRICE1  I PSNPRIC']"" S PSNPRICE="No Price"_" / "_DU D GETRADE,GETRADE1,BUILDIT
    37         Q
    38 PRICE2  I PSNPRIC]"" S PSNPRICE=PSNPRIC D PSNPR1,GETRADE,GETRADE1,BUILDIT
    39         Q
    40 GETRADE1        I '$O(^PSDRUG(PSNB,1,0)) K PSNAR S PSNTRD="ZZXZZXZZX" S PSNAR(1,PSNAME,PSNTRD)=""
    41         Q
    42 GETRADE I $O(^PSDRUG(PSNB,1,0)) K PSNAR F PSNUM=0:0 S PSNUM=$O(^PSDRUG(PSNB,1,PSNUM)) Q:'PSNUM  D TRADE1,TRADE2,TRADE3
    43         Q
    44 TRADE1  I $P(^PSDRUG(PSNB,1,PSNUM,0),"^",3)=1 S PSNTRD="ZZXZZXZZX" S PSNAR(3,PSNAME,"ZZXZZXZZX")=""
    45         Q
    46 TRADE2  I $P(^PSDRUG(PSNB,1,PSNUM,0),"^",3)=0 S PSNTRD=$P(^PSDRUG(PSNB,1,PSNUM,0),"^",1) I PSNTRD]"" S PSNAR(1,PSNAME,PSNTRD)=""
    47         Q
    48 TRADE3  I $P(^PSDRUG(PSNB,1,PSNUM,0),"^",3)="" S PSNTRD="ZZXZZXZZX" S PSNAR(2,PSNAME,"ZZXZZXZZX")=""
    49         Q
    50 BUILDIT F PSNKK=1,2,3 D BUILDIT1
    51         Q
    52 BUILDIT1        S PSNFF="" F  S PSNFF=$O(PSNAR(PSNKK,PSNFF)) Q:PSNFF=""  S PSNGG="" F  S PSNGG=$O(PSNAR(PSNKK,PSNFF,PSNGG)) Q:PSNGG=""  D BUILD
    53         Q
    54 BUILD   S PSNFG=0 I PSNFG=0 S:'$D(^TMP($J,"PSNF",PSNFF)) ^TMP($J,"PSNF",PSNFF,PSNGG,PSNCLSS,PSNPRICE)="" S:PSNGG'="ZZXZZXZZX" ^TMP($J,"PSNF",PSNGG,PSNFF,PSNCLSS,PSNPRICE)=""
    55         Q
    56 LOOP1   S PSNLGN="" F  S PSNLGN=$O(^TMP($J,"PSNF",PSNLGN)) Q:PSNLGN=""  S PSNFLG=1 D LOOP2
    57         Q
    58 LOOP2   S PSNLOC="" F  S PSNLOC=$O(^TMP($J,"PSNF",PSNLGN,PSNLOC)) Q:PSNLOC=""  D LOOP3
    59         Q
    60 LOOP3   S PSNCL="" F  S PSNCL=$O(^TMP($J,"PSNF",PSNLGN,PSNLOC,PSNCL)) Q:PSNCL=""  D LOOP4
    61         Q
    62 LOOP4   S PSNPR="" F  S PSNPR=$O(^TMP($J,"PSNF",PSNLGN,PSNLOC,PSNCL,PSNPR)) Q:PSNPR=""  D WRITE
    63         Q
    64 WRITE   D:$Y>PSNPGLNG TITLE W:PSNFLG !,PSNLGN,! S PSNFLG=0 W ?3 W:PSNLOC'="ZZXZZXZZX" PSNLOC W:PSNLOC="ZZXZZXZZX" " " W ?46,PSNCL,?59,PSNPR,!
    65         Q
    66 DATE    K ^TMP($J,"PSNDT") F PSNB=0:0 S PSNB=$O(^PSDRUG(PSNB)) Q:'PSNB  D DATE0
    67         Q
    68 DATE0   I '$D(^PSDRUG(PSNB,"I")) S ^TMP($J,"PSNDT",PSNB)=""
    69         I $D(^PSDRUG(PSNB,"I")) S PSNDATE=$P(^PSDRUG(PSNB,"I"),"^") D NOW^%DTC I X<PSNDATE S ^TMP($J,"PSNDT",PSNB)="" K PSNDATE,X
    70         Q
    71 PSNPR1   S PSNPRICE=$J(PSNPRIC,3,3),PSNPRICE=PSNPRICE_" / "_DU
    72         Q
    73 CHECK   I SF=0,$P(^PSDRUG(PSNB,0),"^",3)'["S" D GETDATE
    74         I SF=1 D GETDATE
    75         Q
     1PSNHFRM ;BIR/WRT-Report of Hospital Formulary drugs from DRUG file ; 10/18/98 17:48
     2 ;;4.0; NATIONAL DRUG FILE;; 30 Oct 98
     3DVC K IO("Q"),%ZIS,POP,IOP S %ZIS="QM",%ZIS("B")="",%ZIS("A")="DEVICE: " D ^%ZIS G:POP DONE W:$E(IOST)'="P" !!,"This report must be run on a printer.",!! G:$E(IOST)'="P" DVC I POP K IOP,POP,IO("Q") Q
     4QUEUE I $D(IO("Q")) K IO("Q") S ZTRTN="ENQ^PSNHFRM" K ZTSAVE,ZTDTH,ZTSK S PSNDEV=ION_";"_IOST_";"_IOM_";"_IOSL,ZTSAVE("SF")="",ZTSAVE("PSNDEV")="",ZTSAVE("PSNANS")="",ZTDESC="Hospital Formulary Report",ZTIO=""
     5 I  D ^%ZTLOAD K MJT,%ZIS,POP,IOP,ZTSK D ^%ZISC Q
     6ENQ ;ENTRY POINT WHEN QUEUED
     7 D LOOP
     8 I $D(ZTQUEUED) D QUEUE1
     9 U IO
     10ENQ1 S PSNPGCT=0,PSNPGLNG=IOSL-6
     11 D TITLE,LOOP1 W @IOF G DONE
     12TITLE I $D(IOF),IOF]"" W @IOF S PSNPGCT=PSNPGCT+1
     13 W !,PSNANS
     14 S X="T" D ^%DT X ^DD("DD") W ?55,"Date printed: ",Y,!?55,"Page: ",PSNPGCT,!!
     15 W !,"GENERIC/TRADE NAME"
     16 W !,?3,"GENERIC/TRADE NAME",?46,"CLASS",?59,"PRICE / DISP UNT",!
     17 F MJT=1:1:80 W "-"
     18 Q
     19DONE S:$D(ZTQUEUED) ZTREQ="@" K ^TMP($J),PSNB,PSNFLG,PSNAME,PSNCL,PSNCLSS,PSNAR,PSNFF,PSNFG,PSNGG,PSNPR,PSNLGN,PSNPGCT,PSNPGLNG,ZTRTN,Y,PSNDEV,MJT,PSNLOC,PSNKK,PSNPRIC,PSNPRICE
     20 K PSNANS,SF,DU,PSNANSR,PSNTRD,PSNUM,PSNDATE,X,IOP,POP,IO("Q") W:$Y @IOF D ^%ZISC
     21 Q
     22QUEUE1 S IOP=PSNDEV F  D ^%ZIS Q:'POP  H 20
     23 Q
     24LOOP F PSNB=0:0 S PSNB=$O(^PSDRUG(PSNB)) Q:'PSNB  S PSNAME=$P(^PSDRUG(PSNB,0),"^",1),PSNCLSS=$P(^PSDRUG(PSNB,0),"^",2) S:PSNCLSS']"" PSNCLSS="No Class" I $P(^PSDRUG(PSNB,0),"^",9)'=1 D CHECK
     25 Q
     26GETDATE I '$D(^PSDRUG(PSNB,"I")) D GETNODE,GETPRIC
     27 I $D(^PSDRUG(PSNB,"I")) S PSNDATE=$P(^PSDRUG(PSNB,"I"),"^") D NOW^%DTC I X<PSNDATE D GETNODE,GETPRIC
     28 Q
     29GETNODE K X I '$D(^PSDRUG(PSNB,660)) S PSNPRICE="No Price /" D GETRADE,GETRADE1
     30 Q
     31GETPRIC I $D(^PSDRUG(PSNB,660)) S PSNPRIC=$P(^PSDRUG(PSNB,660),"^",6),DU=$P(^PSDRUG(PSNB,660),"^",8) D PRICE1,PRICE2
     32 Q
     33PRICE1 I PSNPRIC']"" S PSNPRICE="No Price"_" / "_DU D GETRADE,GETRADE1,BUILDIT
     34 Q
     35PRICE2 I PSNPRIC]"" S PSNPRICE=PSNPRIC D PSNPR1,GETRADE,GETRADE1,BUILDIT
     36 Q
     37GETRADE1 I '$O(^PSDRUG(PSNB,1,0)) K PSNAR S PSNTRD="ZZXZZXZZX" S PSNAR(1,PSNAME,PSNTRD)=""
     38 Q
     39GETRADE I $O(^PSDRUG(PSNB,1,0)) K PSNAR F PSNUM=0:0 S PSNUM=$O(^PSDRUG(PSNB,1,PSNUM)) Q:'PSNUM  D TRADE1,TRADE2,TRADE3
     40 Q
     41TRADE1 I $P(^PSDRUG(PSNB,1,PSNUM,0),"^",3)=1 S PSNTRD="ZZXZZXZZX" S PSNAR(3,PSNAME,"ZZXZZXZZX")=""
     42 Q
     43TRADE2 I $P(^PSDRUG(PSNB,1,PSNUM,0),"^",3)=0 S PSNTRD=$P(^PSDRUG(PSNB,1,PSNUM,0),"^",1) S PSNAR(1,PSNAME,PSNTRD)=""
     44 Q
     45TRADE3 I $P(^PSDRUG(PSNB,1,PSNUM,0),"^",3)="" S PSNTRD="ZZXZZXZZX" S PSNAR(2,PSNAME,"ZZXZZXZZX")=""
     46 Q
     47BUILDIT F PSNKK=1,2,3 D BUILDIT1
     48 Q
     49BUILDIT1 S PSNFF="" F  S PSNFF=$O(PSNAR(PSNKK,PSNFF)) Q:PSNFF=""  S PSNGG="" F  S PSNGG=$O(PSNAR(PSNKK,PSNFF,PSNGG)) Q:PSNGG=""  D BUILD
     50 Q
     51BUILD S PSNFG=0 I PSNFG=0 S:'$D(^TMP($J,"PSNF",PSNFF)) ^TMP($J,"PSNF",PSNFF,PSNGG,PSNCLSS,PSNPRICE)="" S:PSNGG'="ZZXZZXZZX" ^TMP($J,"PSNF",PSNGG,PSNFF,PSNCLSS,PSNPRICE)=""
     52 Q
     53LOOP1 S PSNLGN="" F  S PSNLGN=$O(^TMP($J,"PSNF",PSNLGN)) Q:PSNLGN=""  S PSNFLG=1 D LOOP2
     54 Q
     55LOOP2 S PSNLOC="" F  S PSNLOC=$O(^TMP($J,"PSNF",PSNLGN,PSNLOC)) Q:PSNLOC=""  D LOOP3
     56 Q
     57LOOP3 S PSNCL="" F  S PSNCL=$O(^TMP($J,"PSNF",PSNLGN,PSNLOC,PSNCL)) Q:PSNCL=""  D LOOP4
     58 Q
     59LOOP4 S PSNPR="" F  S PSNPR=$O(^TMP($J,"PSNF",PSNLGN,PSNLOC,PSNCL,PSNPR)) Q:PSNPR=""  D WRITE
     60 Q
     61WRITE D:$Y>PSNPGLNG TITLE W:PSNFLG !,PSNLGN,! S PSNFLG=0 W ?3 W:PSNLOC'="ZZXZZXZZX" PSNLOC W:PSNLOC="ZZXZZXZZX" " " W ?46,PSNCL,?59,PSNPR,!
     62 Q
     63DATE K ^TMP($J,"PSNDT") F PSNB=0:0 S PSNB=$O(^PSDRUG(PSNB)) Q:'PSNB  D DATE0
     64 Q
     65DATE0 I '$D(^PSDRUG(PSNB,"I")) S ^TMP($J,"PSNDT",PSNB)=""
     66 I $D(^PSDRUG(PSNB,"I")) S PSNDATE=$P(^PSDRUG(PSNB,"I"),"^") D NOW^%DTC I X<PSNDATE S ^TMP($J,"PSNDT",PSNB)="" K PSNDATE,X
     67 Q
     68PSNPR1  S PSNPRICE=$J(PSNPRIC,3,3),PSNPRICE=PSNPRICE_" / "_DU
     69 Q
     70CHECK I SF=0,$P(^PSDRUG(PSNB,0),"^",3)'["S" D GETDATE
     71 I SF=1 D GETDATE
     72 Q
Note: See TracChangeset for help on using the changeset viewer.