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

revised back to 6/30/08 version

File:
1 edited

Legend:

Unmodified
Added
Removed

  • WorldVistAEHR/trunk/r/CONTROLLED_SUBSTANCES-PSD/PSDACT1.m

    r613 r623  
    1 PSDACT1 ;BIR/JPW,BJW-Print Daily Activity Log (cont'd) ; 17 Jun 98
    2         ;;3.0; CONTROLLED SUBSTANCES ;**10,14,30,65**;13 Feb 97;Build 5
    3         ;Reference to ^PRC(442 supported by IA #682
    4         ;Reference to ^PRCS(410 supported by IA #198
    5         ;Reference to ^PSDRUG( supported by IA #221
    6         ;Reference to ^PSRX( supported by IA #986
    7         ;Reference to ^DD(58.81 supported by IA #10154
    8         ;Reference to PSD(58.8 supported by DBIA # 2711
    9         ;Reference to PSD(58.81 supported by DBIA # 2808
    10         ;References to PSD(58.84 supported by IA # 3485
    11         ;modified for nois:tua-0498-32173,new code added to t6
    12         ;op v.7 chg the status loc in file 52
    13 START   ;entry for compile
    14         K ^TMP("PSDACT",$J)
    15         I $D(ALL) F PSDR=0:0 S PSDR=$O(^PSD(58.8,+PSDS,1,PSDR)) Q:'PSDR  I $D(^PSD(58.8,+PSDS,1,PSDR,0)) S PSDRG(+PSDR)=""
    16         F PSD=PSDSD:0 S PSD=$O(^PSD(58.81,"ACT",PSD)) Q:'PSD!(PSD>PSDED)  F PSDR=0:0 S PSDR=$O(^PSD(58.81,"ACT",PSD,PSDS,PSDR)) Q:'PSDR  D
    17         .Q:'$D(PSDRG(PSDR))
    18         .F TYP=0:0 S TYP=$O(^PSD(58.81,"ACT",PSD,PSDS,PSDR,TYP)) Q:'TYP!(TYP=12)  F PSDA=0:0 S PSDA=$O(^PSD(58.81,"ACT",PSD,PSDS,PSDR,TYP,PSDA)) Q:'PSDA  D SET
    19         G:$D(ZTQUEUED) PRTQUE G PRINT^PSDACT2
    20 END     ;
    21         D KVAR^VADPT
    22         K %,%DT,%H,%I,%ZIS,ACT,ALL,BFWD,C,DA,DATE,DIC,DIR,DIROUT,DIRUT,DTOUT,DUOUT,LN,MFG,NAOU,NODE,NQTY,NUM
    23         K PAT,PG,PHARM,POP,PSD,PSDA,PSDATE,PSDED,PSDEV,PSDIO,PSDOUT,PSDPN,PSDR,PSDRG,PSDRGN,PSDS,PSDSD,PSDSN,PSDUZ,PSDUZN,RX,TEXT,TYP,QTY,TYPE,X,Y,VA("BID"),VA("PID")
    24         K ^TMP("PSDACT",$J),ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE,ZTSK
    25         D ^%ZISC S:$D(ZTQUEUED) ZTREQ="@"
    26         Q
    27 SET     ;sets data
    28         ;Dave B (PSD*3*14) Disregard if type is 15.
    29         Q:'$D(^PSD(58.81,PSDA,0))  Q:TYP=5  Q:TYP=15  S NODE=^(0),QTY=$P(NODE,"^",6),BFWD=$P(NODE,"^",10)
    30         S PSDRGN=$S($P($G(^PSDRUG(PSDR,0)),"^")]"":$P(^(0),"^"),1:"ZZ/"_PSDR_" NAME MISSING")
    31         S PSDUZ=$S(TYP=3:+$P($G(^PSD(58.81,PSDA,1)),"^",14),TYP=4:+$P($G(^PSD(58.81,PSDA,1)),"^",14),TYP=13:+$P($G(^PSD(58.81,PSDA,5)),"^",2),TYP=14:+$P($G(^PSD(58.81,PSDA,4)),"^",2),1:+$P(NODE,"^",7))
    32         S:TYP=2 PSDUZ=$S(+$P($G(^PSD(58.81,PSDA,1)),"^"):+$P($G(^(1)),"^"),1:+$P(NODE,"^",7))
    33         S PSDUZN=$P($G(^VA(200,+PSDUZ,0)),"^"),PSDUZN=$S(PSDUZN]"":$E($P(PSDUZN,",",2))_$E(PSDUZN),1:"**")
    34         I TYP=1 D T1 G TMP
    35         I TYP=2 D T2 G TMP
    36         I TYP=3 Q:'$D(^PSD(58.81,PSDA,3))  D T3 G TMP
    37         Q:TYP=4
    38         I TYP=6 Q:'$D(^PSD(58.81,PSDA,6))  D T6 G TMP
    39         I TYP=7 D T7 G TMP
    40         I TYP=9 D T9 G TMP
    41         I TYP=11 D T11 G TMP
    42         I TYP=13 Q:'$D(^PSD(58.81,PSDA,5))  D T13 G TMP
    43         I TYP=14 Q:'$D(^PSD(58.81,PSDA,4))  D T14 G TMP
    44         I TYP=16 D T16 G TMP
    45         I TYP>18 D TOTH
    46 TMP     ;
    47         S PSDUZN=$P($G(^VA(200,+PSDUZ,0)),"^"),PSDUZN=$S(PSDUZN]"":$E($P(PSDUZN,",",2))_$E(PSDUZN),1:"**")
    48         ;PSD*3*30 (Dave B - Identify person with more than just **)
    49         I $G(PSDUZN)="**" S PSDUZ=$P($G(^PSD(58.81,PSDA,0)),"^",7),PSDUZN=$P($G(^VA(200,+PSDUZ,0)),"^"),PSDUZN=$S(PSDUZN]"":$E($P(PSDUZN,",",2))_$E(PSDUZN),1:"**")
    50         S ^TMP("PSDACT",$J,PSDRGN,PSD,TYP,PSDA)=BFWD_"^"_NUM_"^"_TEXT_"^"_QTY_"^"_PSDUZN I $D(PSDRTS) S ^TMP("PSDACT",$J,PSDRGN,PSD,TYP,PSDA)=^TMP("PSDACT",$J,PSDRGN,PSD,TYP,PSDA)_"^1"
    51         K PSDRTS Q
    52 T1      S NUM="***",TEXT="RECEIPT INTO PHARMACY"
    53         I $P($G(^PSD(58.81,PSDA,8)),"^")]"" S NUM=$P($G(^PSD(58.81,PSDA,8)),"^") Q
    54         I +$P(NODE,"^",9) S NUM=+$P(NODE,"^",9),NUM=$P($G(^PRC(442,NUM,0)),"^") Q
    55         I +$P(NODE,"^",8) S NUM=+$P(NODE,"^",8),NUM=$P($G(^PRCS(410,NUM,0)),"^") Q
    56         Q
    57 T2      S QTY=-QTY,NUM="DISP",NAOU=+$P(NODE,"^",18) S:NAOU NAOU=$P($G(^PSD(58.8,+NAOU,0)),"^") S TEXT=$S(NAOU]"":NAOU,1:"DISPENSED FROM PHARMACY")
    58         I +$P(NODE,"^",17) S NUM="GS # "_$P(NODE,"^",17)
    59         Q
    60 T3      S NUM="GS # ",TEXT="RETURNED TO STOCK"
    61         I +$P(NODE,"^",17) S NUM=NUM_$P(NODE,"^",17)
    62         ;PSD*3*30 (Dave B - more precise infor on RTS)
    63         I $G(NUM)="GS # " D
    64         .S RX=$P($G(^PSD(58.81,PSDA,6)),"^"),RXNUM=$P($G(^PSD(58.81,PSDA,6)),"^",5)
    65         .S PAT=$P($G(^PSRX(RX,0)),"^",2) I PAT S DFN=PAT D PID^VADPT6 S Y=PAT,C=$P(^DD(58.81,73,0),"^",2) D Y^DIQ S TEXT=Y_"("_VA("BID")_")" K DFN,VA("BID"),VA("PID")
    66         .S NUM="RX # "_$G(RXNUM)_" ("_$S($P($G(^PSD(58.81,PSDA,6)),U,2):"R"_$P($G(^(6)),U,2),$P($G(^(6)),U,4):"P"_$P($G(^(6)),U,4),1:"O")_")"
    67         .S QTY=$P(^PSD(58.81,PSDA,3),"^",2),BFWD=$P(^PSD(58.81,PSDA,0),"^",10),PSDRTS=1 Q
    68         I $G(PSDRTS)=1 Q
    69         S QTY=$P(^PSD(58.81,PSDA,3),"^",2),BFWD=$P(^(3),"^",7)
    70         Q
    71 T6      S QTY=-QTY,NUM="RX # ",TEXT="OUTPATIENT RX" N RXNUM
    72         S RX=+$P(^PSD(58.81,PSDA,6),"^"),RXNUM=$S($P(^(6),"^",5)]"":$P(^(6),"^",5),$P($G(^PSRX(RX,0)),"^")]"":$P(^(0),"^"),1:"UNKNOWN"),NUM=NUM_RXNUM
    73         S NUM=NUM_" ("_$S($P($G(^PSD(58.81,PSDA,6)),U,2):"R"_$P($G(^(6)),U,2),$P($G(^(6)),U,4):"P"_$P($G(^(6)),U,4),1:"O")_")"
    74         S PAT=+$P($G(^PSRX(RX,0)),"^",2)
    75         S PSDRXIN=RX D VER^PSDOPT
    76         ;W !,TEXT,"  ",RXNUM
    77         S TEXT=$S('$O(^PSRX("B",RXNUM,0)):"RX DELETED",$G(PSDSTA)=13:"RX DELETED",1:"UNKNOWN")
    78         ;W !,TEXT
    79         K PSDSTA,PSOVR,PSDRXIN
    80         I PAT S DFN=PAT D PID^VADPT6 D
    81         .K C S Y=PAT,C=$P(^DD(58.81,73,0),"^",2) D Y^DIQ S TEXT=Y_" ("_VA("BID")_")" K DFN,VA("BID"),VA("PID")
    82         Q
    83 T7      S NUM="GS # ",TEXT="CANCEL UNVERIFIED ORDER",QTY=0
    84         I +$P(NODE,"^",17) S NUM=NUM_$P(NODE,"^",17)
    85         Q
    86 T9      S NUM="ADJ",TEXT=$S($D(^PSD(58.81,+PSDA,9)):$P(NODE,"^",16),1:"ADJUSTMENT")
    87         I $P(NODE,"^",16)]"" S TEXT=$P(NODE,"^",16)
    88         I $D(^PSD(58.81,PSDA,3)) S NUM="DEST # "_$P(^(3),"^",8),TEXT="HOLDING FOR DESTRUCTION"
    89         Q
    90 T11     S NUM="***",TEXT="INITIALIZE BALANCE AT SETUP"
    91         Q
    92 T13     S NUM="GS # ",TEXT="CANCEL VERIFIED ORDER"
    93         I +$P(NODE,"^",17) S NUM=NUM_$P(NODE,"^",17)
    94         S QTY=$P(^PSD(58.81,PSDA,5),"^",3),BFWD=$P(^(5),"^",5)
    95         Q
    96 T14     S NUM="GS # ",TEXT="EDIT VERIFIED ORDER"
    97         I +$P(NODE,"^",17) S NUM=NUM_$P(NODE,"^",17)
    98         S:$D(^PSD(58.81,PSDA,8)) TEXT="EDIT VERIFIED INVOICE",NUM=$P(^PSD(58.81,PSDA,8),"^",1) ; <*65-RJS>
    99         S QTY=$P(^PSD(58.81,PSDA,4),"^",4),BFWD=$P(^(4),"^",7)
    100         Q
    101 T16     S NUM="TRV",TEXT="TRANSFER TO VAULT"
    102         Q
    103 TOTH    ;Type = 19,20,21,22
    104         S NUM="INV",TEXT=$G(^PSD(58.84,+TYP,0)),QTY=""
    105         Q
    106 PRTQUE  ;queues print after compile
    107         K ZTSAVE,ZTIO S ZTIO=PSDIO,ZTRTN="PRINT^PSDACT2",ZTDESC="CS PHARM Print Daily Activity Log",ZTDTH=$H,ZTSAVE("^TMP(""PSDACT"",$J,")="",ZTSAVE("PSDSN")="",ZTSAVE("PSDATE")=""
    108         D ^%ZTLOAD K ZTSK G END
     1PSDACT1 ;BIR/JPW,BJW-Print Daily Activity Log (cont'd) ; 17 Jun 98
     2 ;;3.0; CONTROLLED SUBSTANCES ;**10,14,30**;13 Feb 97
     3 ;Reference to ^PRC(442 supported by IA #682
     4 ;Reference to ^PRCS(410 supported by IA #198
     5 ;Reference to ^PSDRUG( supported by IA #221
     6 ;Reference to ^PSRX( supported by IA #986
     7 ;Reference to ^DD(58.81 supported by IA #10154
     8 ;Reference to PSD(58.8 supported by DBIA # 2711
     9 ;Reference to PSD(58.81 supported by DBIA # 2808
     10 ;References to PSD(58.84 supported by IA # 3485
     11 ;modified for nois:tua-0498-32173,new code added to t6
     12 ;op v.7 chg the status loc in file 52
     13START ;entry for compile
     14 K ^TMP("PSDACT",$J)
     15 I $D(ALL) F PSDR=0:0 S PSDR=$O(^PSD(58.8,+PSDS,1,PSDR)) Q:'PSDR  I $D(^PSD(58.8,+PSDS,1,PSDR,0)) S PSDRG(+PSDR)=""
     16 F PSD=PSDSD:0 S PSD=$O(^PSD(58.81,"ACT",PSD)) Q:'PSD!(PSD>PSDED)  F PSDR=0:0 S PSDR=$O(^PSD(58.81,"ACT",PSD,PSDS,PSDR)) Q:'PSDR  D
     17 .Q:'$D(PSDRG(PSDR))
     18 .F TYP=0:0 S TYP=$O(^PSD(58.81,"ACT",PSD,PSDS,PSDR,TYP)) Q:'TYP!(TYP=12)  F PSDA=0:0 S PSDA=$O(^PSD(58.81,"ACT",PSD,PSDS,PSDR,TYP,PSDA)) Q:'PSDA  D SET
     19 G:$D(ZTQUEUED) PRTQUE G PRINT^PSDACT2
     20END ;
     21 D KVAR^VADPT
     22 K %,%DT,%H,%I,%ZIS,ACT,ALL,BFWD,C,DA,DATE,DIC,DIR,DIROUT,DIRUT,DTOUT,DUOUT,LN,MFG,NAOU,NODE,NQTY,NUM
     23 K PAT,PG,PHARM,POP,PSD,PSDA,PSDATE,PSDED,PSDEV,PSDIO,PSDOUT,PSDPN,PSDR,PSDRG,PSDRGN,PSDS,PSDSD,PSDSN,PSDUZ,PSDUZN,RX,TEXT,TYP,QTY,TYPE,X,Y,VA("BID"),VA("PID")
     24 K ^TMP("PSDACT",$J),ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE,ZTSK
     25 D ^%ZISC S:$D(ZTQUEUED) ZTREQ="@"
     26 Q
     27SET ;sets data
     28 ;Dave B (PSD*3*14) Disregard if type is 15.
     29 Q:'$D(^PSD(58.81,PSDA,0))  Q:TYP=5  Q:TYP=15  S NODE=^(0),QTY=$P(NODE,"^",6),BFWD=$P(NODE,"^",10)
     30 S PSDRGN=$S($P($G(^PSDRUG(PSDR,0)),"^")]"":$P(^(0),"^"),1:"ZZ/"_PSDR_" NAME MISSING")
     31 S PSDUZ=$S(TYP=3:+$P($G(^PSD(58.81,PSDA,1)),"^",14),TYP=4:+$P($G(^PSD(58.81,PSDA,1)),"^",14),TYP=13:+$P($G(^PSD(58.81,PSDA,5)),"^",2),TYP=14:+$P($G(^PSD(58.81,PSDA,4)),"^",2),1:+$P(NODE,"^",7))
     32 S:TYP=2 PSDUZ=$S(+$P($G(^PSD(58.81,PSDA,1)),"^"):+$P($G(^(1)),"^"),1:+$P(NODE,"^",7))
     33 S PSDUZN=$P($G(^VA(200,+PSDUZ,0)),"^"),PSDUZN=$S(PSDUZN]"":$E($P(PSDUZN,",",2))_$E(PSDUZN),1:"**")
     34 I TYP=1 D T1 G TMP
     35 I TYP=2 D T2 G TMP
     36 I TYP=3 Q:'$D(^PSD(58.81,PSDA,3))  D T3 G TMP
     37 Q:TYP=4
     38 I TYP=6 Q:'$D(^PSD(58.81,PSDA,6))  D T6 G TMP
     39 I TYP=7 D T7 G TMP
     40 I TYP=9 D T9 G TMP
     41 I TYP=11 D T11 G TMP
     42 I TYP=13 Q:'$D(^PSD(58.81,PSDA,5))  D T13 G TMP
     43 I TYP=14 Q:'$D(^PSD(58.81,PSDA,4))  D T14 G TMP
     44 I TYP=16 D T16 G TMP
     45 I TYP>18 D TOTH
     46TMP ;
     47 S PSDUZN=$P($G(^VA(200,+PSDUZ,0)),"^"),PSDUZN=$S(PSDUZN]"":$E($P(PSDUZN,",",2))_$E(PSDUZN),1:"**")
     48 ;PSD*3*30 (Dave B - Identify person with more than just **)
     49 I $G(PSDUZN)="**" S PSDUZ=$P($G(^PSD(58.81,PSDA,0)),"^",7),PSDUZN=$P($G(^VA(200,+PSDUZ,0)),"^"),PSDUZN=$S(PSDUZN]"":$E($P(PSDUZN,",",2))_$E(PSDUZN),1:"**")
     50 S ^TMP("PSDACT",$J,PSDRGN,PSD,TYP,PSDA)=BFWD_"^"_NUM_"^"_TEXT_"^"_QTY_"^"_PSDUZN I $D(PSDRTS) S ^TMP("PSDACT",$J,PSDRGN,PSD,TYP,PSDA)=^TMP("PSDACT",$J,PSDRGN,PSD,TYP,PSDA)_"^1"
     51 K PSDRTS Q
     52T1 S NUM="***",TEXT="RECEIPT INTO PHARMACY"
     53 I $P($G(^PSD(58.81,PSDA,8)),"^")]"" S NUM=$P($G(^PSD(58.81,PSDA,8)),"^") Q
     54 I +$P(NODE,"^",9) S NUM=+$P(NODE,"^",9),NUM=$P($G(^PRC(442,NUM,0)),"^") Q
     55 I +$P(NODE,"^",8) S NUM=+$P(NODE,"^",8),NUM=$P($G(^PRCS(410,NUM,0)),"^") Q
     56 Q
     57T2 S QTY=-QTY,NUM="DISP",NAOU=+$P(NODE,"^",18) S:NAOU NAOU=$P($G(^PSD(58.8,+NAOU,0)),"^") S TEXT=$S(NAOU]"":NAOU,1:"DISPENSED FROM PHARMACY")
     58 I +$P(NODE,"^",17) S NUM="GS # "_$P(NODE,"^",17)
     59 Q
     60T3 S NUM="GS # ",TEXT="RETURNED TO STOCK"
     61 I +$P(NODE,"^",17) S NUM=NUM_$P(NODE,"^",17)
     62 ;PSD*3*30 (Dave B - more precise infor on RTS)
     63 I $G(NUM)="GS # " D
     64 .S RX=$P($G(^PSD(58.81,PSDA,6)),"^"),RXNUM=$P($G(^PSD(58.81,PSDA,6)),"^",5)
     65 .S PAT=$P($G(^PSRX(RX,0)),"^",2) I PAT S DFN=PAT D PID^VADPT6 S Y=PAT,C=$P(^DD(58.81,73,0),"^",2) D Y^DIQ S TEXT=Y_"("_VA("BID")_")" K DFN,VA("BID"),VA("PID")
     66 .S NUM="RX # "_$G(RXNUM)_" ("_$S($P($G(^PSD(58.81,PSDA,6)),U,2):"R"_$P($G(^(6)),U,2),$P($G(^(6)),U,4):"P"_$P($G(^(6)),U,4),1:"O")_")"
     67 .S QTY=$P(^PSD(58.81,PSDA,3),"^",2),BFWD=$P(^PSD(58.81,PSDA,0),"^",10),PSDRTS=1 Q
     68 I $G(PSDRTS)=1 Q
     69 S QTY=$P(^PSD(58.81,PSDA,3),"^",2),BFWD=$P(^(3),"^",7)
     70 Q
     71T6 S QTY=-QTY,NUM="RX # ",TEXT="OUTPATIENT RX" N RXNUM
     72 S RX=+$P(^PSD(58.81,PSDA,6),"^"),RXNUM=$S($P(^(6),"^",5)]"":$P(^(6),"^",5),$P($G(^PSRX(RX,0)),"^")]"":$P(^(0),"^"),1:"UNKNOWN"),NUM=NUM_RXNUM
     73 S NUM=NUM_" ("_$S($P($G(^PSD(58.81,PSDA,6)),U,2):"R"_$P($G(^(6)),U,2),$P($G(^(6)),U,4):"P"_$P($G(^(6)),U,4),1:"O")_")"
     74 S PAT=+$P($G(^PSRX(RX,0)),"^",2)
     75 S PSDRXIN=RX D VER^PSDOPT
     76 ;W !,TEXT,"  ",RXNUM
     77 S TEXT=$S('$O(^PSRX("B",RXNUM,0)):"RX DELETED",$G(PSDSTA)=13:"RX DELETED",1:"UNKNOWN")
     78 ;W !,TEXT
     79 K PSDSTA,PSOVR,PSDRXIN
     80 I PAT S DFN=PAT D PID^VADPT6 D
     81 .K C S Y=PAT,C=$P(^DD(58.81,73,0),"^",2) D Y^DIQ S TEXT=Y_" ("_VA("BID")_")" K DFN,VA("BID"),VA("PID")
     82 Q
     83T7 S NUM="GS # ",TEXT="CANCEL UNVERIFIED ORDER",QTY=0
     84 I +$P(NODE,"^",17) S NUM=NUM_$P(NODE,"^",17)
     85 Q
     86T9 S NUM="ADJ",TEXT=$S($D(^PSD(58.81,+PSDA,9)):$P(NODE,"^",16),1:"ADJUSTMENT")
     87 I $P(NODE,"^",16)]"" S TEXT=$P(NODE,"^",16)
     88 I $D(^PSD(58.81,PSDA,3)) S NUM="DEST # "_$P(^(3),"^",8),TEXT="HOLDING FOR DESTRUCTION"
     89 Q
     90T11 S NUM="***",TEXT="INITIALIZE BALANCE AT SETUP"
     91 Q
     92T13 S NUM="GS # ",TEXT="CANCEL VERIFIED ORDER"
     93 I +$P(NODE,"^",17) S NUM=NUM_$P(NODE,"^",17)
     94 S QTY=$P(^PSD(58.81,PSDA,5),"^",3),BFWD=$P(^(5),"^",5)
     95 Q
     96T14 S NUM="GS # ",TEXT="EDIT VERIFIED ORDER"
     97 I +$P(NODE,"^",17) S NUM=NUM_$P(NODE,"^",17)
     98 S QTY=$P(^PSD(58.81,PSDA,4),"^",4),BFWD=$P(^(4),"^",7)
     99 Q
     100T16 S NUM="TRV",TEXT="TRANSFER TO VAULT"
     101 Q
     102TOTH ;Type = 19,20,21,22
     103 S NUM="INV",TEXT=$G(^PSD(58.84,+TYP,0)),QTY=""
     104 Q
     105PRTQUE ;queues print after compile
     106 K ZTSAVE,ZTIO S ZTIO=PSDIO,ZTRTN="PRINT^PSDACT2",ZTDESC="CS PHARM Print Daily Activity Log",ZTDTH=$H,ZTSAVE("^TMP(""PSDACT"",$J,")="",ZTSAVE("PSDSN")="",ZTSAVE("PSDATE")=""
     107 D ^%ZTLOAD K ZTSK G END
Note: See TracChangeset for help on using the changeset viewer.