Changeset 623 for WorldVistAEHR/trunk/r/CONTROLLED_SUBSTANCES-PSD
- Timestamp:
- Dec 4, 2009, 12:11:15 AM (15 years ago)
- Location:
- WorldVistAEHR/trunk/r/CONTROLLED_SUBSTANCES-PSD
- Files:
-
- 5 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 1 PSDACT1 ;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 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 QTY=$P(^PSD(58.81,PSDA,4),"^",4),BFWD=$P(^(4),"^",7) 99 Q 100 T16 S NUM="TRV",TEXT="TRANSFER TO VAULT" 101 Q 102 TOTH ;Type = 19,20,21,22 103 S NUM="INV",TEXT=$G(^PSD(58.84,+TYP,0)),QTY="" 104 Q 105 PRTQUE ;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 -
WorldVistAEHR/trunk/r/CONTROLLED_SUBSTANCES-PSD/PSDNRGS.m
r613 r623 1 PSDNRGS ;BIR/JPW-Receive Green Sheet for NAOU ; 6 Jan 94 2 ;;3.0; CONTROLLED SUBSTANCES ;**56,66,65**;13 Feb 97;Build 5 3 I '$D(PSDSITE) D ^PSDSET Q:'$D(PSDSITE) 4 S OK=$S($D(^XUSEC("PSJ RNURSE",DUZ)):1,$D(^XUSEC("PSD NURSE",DUZ)):1,$D(^XUSEC("PSJ RPHARM",DUZ)):2,$D(^XUSEC("PSJ PHARM TECH",DUZ)):2,1:0) 5 I 'OK W $C(7),!!,?9,"** Please contact your Coordinator for access to complete",!,?12,"narcotic orders.",!!,"PSJ RNURSE, PSD NURSE, PSJ RPHARM, or PSJ PHARM TECH security key required.",! K OK Q 6 I $P($G(^VA(200,DUZ,20)),U,4)']"" N XQH S XQH="PSD ESIG" D EN^XQH Q 7 W !!,"Receive Controlled Substances Orders and Green Sheet" S PSDUZ=DUZ,PSDUZN=$S($P($G(^VA(200,PSDUZ,0)),"^")]"":$P(^(0),"^"),1:"") 8 N X,X1 D SIG^XUSESIG Q:X1="" 9 ASKN ;ask naou 10 W ! K DA,DIC S DIC=58.8,DIC(0)="QEAZ",DIC("A")="Select NAOU: " 11 S:OK=1 DIC("S")="I $P(^(0),""^"",3)=+PSDSITE,$S('$D(^(""I"")):1,'^(""I""):1,+^(""I"")>DT:1,1:0),$P(^(0),""^"",2)=""N"",'$P(^(0),""^"",7)" 12 S:OK=2 DIC("S")="I $P(^(0),""^"",3)=+PSDSITE,$S('$D(^(""I"")):1,'^(""I""):1,+^(""I"")>DT:1,1:0),$P(^(0),""^"",2)=""N""" 13 D ^DIC K DIC G:Y<0 END S AOU=+Y,AOUN=$P(Y,"^",2) 14 GS ;select green sheet # 15 W ! K DA,DIC S DIC("A")="Select the Green Sheet #: ",DIC=58.81,DIC(0)="QEASZ",D="D" 16 S DIC("S")="I $P(^(0),""^"",11),$P(^(0),""^"",11)<12" 17 D IX^DIC K DIC G:Y<0 ASKN S PSDA=+Y 18 ORD S STAT=+$P(Y(0),"^",11),PSDPN=$P(Y(0),"^",17),STATN="" I STAT S STATN=$P($G(^PSD(58.82,STAT,0)),"^") 19 S ORD=+$P(Y(0),"^",20),NAOU=+$P(Y(0),"^",18),NAOUN=$P($G(^PSD(58.8,NAOU,0)),"^"),PSDR=+$P(Y(0),"^",5),PSDRN=$P($G(^PSDRUG(PSDR,0)),"^"),QTY=+$P(Y(0),"^",6) 20 ; >> RJS - *65 21 L +^PSD(58.81,PSDA):$S($G(DILOCKTM)>0:DILOCKTM,1:3) 22 I '$T W !,"The Green Sheet # ",PSDPN," is currently in use by another user",!,"Please select another Green Sheet.",! G GS 23 I $D(^PSD(58.81,PSDA,4)),+$P(^(4),"^",3) S QTY=$P(^(4),"^",3) 24 I AOU'=NAOU W $C(7),!!,"The Green Sheet # ",PSDPN," is assigned to ",NAOUN,".",!,"Please select another Green Sheet.",! L -^PSD(58.81,PSDA) G GS ; <RJS - *65 25 I '$D(^PSD(58.8,NAOU,1,PSDR,3,ORD,0)) W $C(7),!!,"There's no data on ",NAOUN," for Green Sheet # ",PSDPN,".",!,"Contact your Pharmacy Coordinator for assistance.",! L -^PSD(58.81,PSDA) G END ; <RJS - *65 26 I STAT'=3 W $C(7),!!,"This Green Sheet has a status of "_$S(STATN]"":STATN,1:"UNKNOWN")_".",!,"Please select another Green Sheet.",! L -^PSD(58.81,PSDA) G GS ; RJS - *65 27 D NOW^%DTC S (RECD,Y)=+$E(%,1,12) X ^DD("DD") S RECDT=Y 28 REC ;receive at order level in 58.8 29 W !!,"Accessing ",PSDRN," information...",!! 30 K DA,DIR,DIRUT S DIR(0)="58.81,27",DIR("B")=QTY D ^DIR K DIR I $D(DIRUT) W !!,"Quantity not entered. No action taken.",!,"This order remains ",STATN,!! L -^PSD(58.81,PSDA) G END ; < RJS - *65 31 S RQTY=Y I RQTY'=QTY W $C(7),!!,"The quantity received does not match the quantity dispensed.",!,"This order must be returned to pharmacy for investigation.",!! L -^PSD(58.81,PSDA) G GS ;< RJS - *65 32 K DA,DIE,DR S DA=ORD,DA(1)=PSDR,DA(2)=NAOU 33 S DIE="^PSD(58.8,"_DA(2)_",1,"_DA(1)_",3," 34 S DR=$S(OK=1:"6////"_PSDUZ,1:"6RECEIVED BY NURSE")_";20////"_QTY_";15////"_RECD_";10////4;22////"_$P($G(^PSD(58.8,NAOU,1,PSDR,0)),U,4)_";25////"_$P($G(^PSD(58.8,NAOU,1,PSDR,0)),U,4) D ^DIE K DA,DIE,DR 35 I ($D(Y))!($D(DTOUT)) W $C(7),!!,"*** THIS ORDER HAS NOT BEEN RECEIVED ***",!,"Receiving nurses name must be entered.",!!,"The status remains "_STATN,! L -^PSD(58.81,PSDA) G END ;< RJS - *65 36 UPDATE ;update 58.8 and 58.81 37 ;updating drug balance in 58.8 38 F L +^PSD(58.8,NAOU,1,PSDR,0):$S($G(DILOCKTM)>0:DILOCKTM,1:3) I Q 39 ;PSD*3*56;REMOVED CHECK FOR PATIENT ID 40 S $P(^PSD(58.8,NAOU,1,PSDR,0),"^",4)=$P(^PSD(58.8,NAOU,1,PSDR,0),"^",4)+QTY 41 L -^PSD(58.8,NAOU,1,PSDR,0) 42 ;update transaction file (58.81) 43 S OREC=$P($G(^PSD(58.8,NAOU,1,PSDR,3,ORD,0)),"^",7) 44 K DA,DIE,DR S DA=PSDA,DIE=58.81 45 S DR="10////"_$S('$P($G(^PSD(58.8,NAOU,2)),U,5):4,$P($G(^PSD(58.81,PSDA,9)),U):4,1:13)_";20////"_OREC_";21////"_RECD_";27////"_QTY_";I OK=1 S Y=""@1"";15COMMENTS;@1" 46 D ^DIE K DA,DIE,DR 47 I OK=2 S $P(^PSD(58.81,PSDA,1),"^",11)=PSDUZ 48 W !!,"Updating your records now..." 49 ;update worksheet file (58.85) to be purged 50 S DA=+$O(^PSD(58.85,"AD",NAOU,PSDR,ORD,0)) I DA,$D(^PSD(58.85,DA,0)) K DIE,DR S DIE=58.85,DR="6////4" D ^DIE K DA,DIE,DR 51 W "done.",!! 52 S STAT=$P($G(^PSD(58.81,PSDA,0)),"^",11) W ?5,"*** Your Green Sheet #"_PSDPN_" is now "_$S($P($G(^PSD(58.82,STAT,0)),"^")]"":$P(^(0),"^"),1:"UNKNOWN")_" ***",! 53 L -^PSD(58.81,PSDA) ;< RJS - *65 54 G GS 55 END K %,%DT,%H,%I,AOU,AOUN,D,DA,DIC,DIE,DR,DTOUT,DUOUT 56 K NAOU,NAOUN,OK,ORD,OREC,PSDPN,PSDR,PSDRN,PSDUZ,PSDUZN,QTY,RECD,RECDT,RQTY,STAT,STATN,SUB,PSDA,X,Y 57 Q 1 PSDNRGS ;BIR/JPW-Receive Green Sheet for NAOU ; 6 Jan 94 2 ;;3.0; CONTROLLED SUBSTANCES ;**56,66**;13 Feb 97;Build 3 3 I '$D(PSDSITE) D ^PSDSET Q:'$D(PSDSITE) 4 S OK=$S($D(^XUSEC("PSJ RNURSE",DUZ)):1,$D(^XUSEC("PSD NURSE",DUZ)):1,$D(^XUSEC("PSJ RPHARM",DUZ)):2,$D(^XUSEC("PSJ PHARM TECH",DUZ)):2,1:0) 5 I 'OK W $C(7),!!,?9,"** Please contact your Coordinator for access to complete",!,?12,"narcotic orders.",!!,"PSJ RNURSE, PSD NURSE, PSJ RPHARM, or PSJ PHARM TECH security key required.",! K OK Q 6 I $P($G(^VA(200,DUZ,20)),U,4)']"" N XQH S XQH="PSD ESIG" D EN^XQH Q 7 W !!,"Receive Controlled Substances Orders and Green Sheet" S PSDUZ=DUZ,PSDUZN=$S($P($G(^VA(200,PSDUZ,0)),"^")]"":$P(^(0),"^"),1:"") 8 N X,X1 D SIG^XUSESIG Q:X1="" 9 ASKN ;ask naou 10 W ! K DA,DIC S DIC=58.8,DIC(0)="QEAZ",DIC("A")="Select NAOU: " 11 S:OK=1 DIC("S")="I $P(^(0),""^"",3)=+PSDSITE,$S('$D(^(""I"")):1,'^(""I""):1,+^(""I"")>DT:1,1:0),$P(^(0),""^"",2)=""N"",'$P(^(0),""^"",7)" 12 S:OK=2 DIC("S")="I $P(^(0),""^"",3)=+PSDSITE,$S('$D(^(""I"")):1,'^(""I""):1,+^(""I"")>DT:1,1:0),$P(^(0),""^"",2)=""N""" 13 D ^DIC K DIC G:Y<0 END S AOU=+Y,AOUN=$P(Y,"^",2) 14 GS ;select green sheet # 15 W ! K DA,DIC S DIC("A")="Select the Green Sheet #: ",DIC=58.81,DIC(0)="QEASZ",D="D" 16 S DIC("S")="I $P(^(0),""^"",11),$P(^(0),""^"",11)<12" 17 D IX^DIC K DIC G:Y<0 ASKN S PSDA=+Y 18 ORD S STAT=+$P(Y(0),"^",11),PSDPN=$P(Y(0),"^",17),STATN="" I STAT S STATN=$P($G(^PSD(58.82,STAT,0)),"^") 19 S ORD=+$P(Y(0),"^",20),NAOU=+$P(Y(0),"^",18),NAOUN=$P($G(^PSD(58.8,NAOU,0)),"^"),PSDR=+$P(Y(0),"^",5),PSDRN=$P($G(^PSDRUG(PSDR,0)),"^"),QTY=+$P(Y(0),"^",6) 20 I $D(^PSD(58.81,PSDA,4)),+$P(^(4),"^",3) S QTY=$P(^(4),"^",3) 21 I AOU'=NAOU W $C(7),!!,"The Green Sheet # ",PSDPN," is assigned to ",NAOUN,".",!,"Please select another Green Sheet.",! G GS 22 I '$D(^PSD(58.8,NAOU,1,PSDR,3,ORD,0)) W $C(7),!!,"There's no data on ",NAOUN," for Green Sheet # ",PSDPN,".",!,"Contact your Pharmacy Coordinator for assistance.",! G END 23 I STAT'=3 W $C(7),!!,"This Green Sheet has a status of "_$S(STATN]"":STATN,1:"UNKNOWN")_".",!,"Please select another Green Sheet.",! G GS 24 D NOW^%DTC S (RECD,Y)=+$E(%,1,12) X ^DD("DD") S RECDT=Y 25 REC ;receive at order level in 58.8 26 W !!,"Accessing ",PSDRN," information...",!! 27 K DA,DIR,DIRUT S DIR(0)="58.81,27",DIR("B")=QTY D ^DIR K DIR I $D(DIRUT) W !!,"Quantity not entered. No action taken.",!,"This order remains ",STATN,!! G END 28 S RQTY=Y I RQTY'=QTY W $C(7),!!,"The quantity received does not match the quantity dispensed.",!,"This order must be returned to pharmacy for investigation.",!! G GS 29 K DA,DIE,DR S DA=ORD,DA(1)=PSDR,DA(2)=NAOU 30 S DIE="^PSD(58.8,"_DA(2)_",1,"_DA(1)_",3," 31 S DR=$S(OK=1:"6////"_PSDUZ,1:"6RECEIVED BY NURSE")_";20////"_QTY_";15////"_RECD_";10////4;22////"_$P($G(^PSD(58.8,NAOU,1,PSDR,0)),U,4)_";25////"_$P($G(^PSD(58.8,NAOU,1,PSDR,0)),U,4) D ^DIE K DA,DIE,DR 32 I ($D(Y))!($D(DTOUT)) W $C(7),!!,"*** THIS ORDER HAS NOT BEEN RECEIVED ***",!,"Receiving nurses name must be entered.",!!,"The status remains "_STATN,! G END 33 UPDATE ;update 58.8 and 58.81 34 ;updating drug balance in 58.8 35 F L +^PSD(58.8,NAOU,1,PSDR,0):$S($G(DILOCKTM)>0:DILOCKTM,1:3) I Q 36 ;PSD*3*56;REMOVED CHECK FOR PATIENT ID 37 S $P(^PSD(58.8,NAOU,1,PSDR,0),"^",4)=$P(^PSD(58.8,NAOU,1,PSDR,0),"^",4)+QTY 38 L -^PSD(58.8,NAOU,1,PSDR,0) 39 ;update transaction file (58.81) 40 S OREC=$P($G(^PSD(58.8,NAOU,1,PSDR,3,ORD,0)),"^",7) 41 K DA,DIE,DR S DA=PSDA,DIE=58.81 42 S DR="10////"_$S('$P($G(^PSD(58.8,NAOU,2)),U,5):4,$P($G(^PSD(58.81,PSDA,9)),U):4,1:13)_";20////"_OREC_";21////"_RECD_";27////"_QTY_";I OK=1 S Y=""@1"";15COMMENTS;@1" 43 D ^DIE K DA,DIE,DR 44 I OK=2 S $P(^PSD(58.81,PSDA,1),"^",11)=PSDUZ 45 W !!,"Updating your records now..." 46 ;update worksheet file (58.85) to be purged 47 S DA=+$O(^PSD(58.85,"AD",NAOU,PSDR,ORD,0)) I DA,$D(^PSD(58.85,DA,0)) K DIE,DR S DIE=58.85,DR="6////4" D ^DIE K DA,DIE,DR 48 W "done.",!! 49 S STAT=$P($G(^PSD(58.81,PSDA,0)),"^",11) W ?5,"*** Your Green Sheet #"_PSDPN_" is now "_$S($P($G(^PSD(58.82,STAT,0)),"^")]"":$P(^(0),"^"),1:"UNKNOWN")_" ***",! 50 G GS 51 END K %,%DT,%H,%I,AOU,AOUN,D,DA,DIC,DIE,DR,DTOUT,DUOUT 52 K NAOU,NAOUN,OK,ORD,OREC,PSDPN,PSDR,PSDRN,PSDUZ,PSDUZN,QTY,RECD,RECDT,RQTY,STAT,STATN,SUB,PSDA,X,Y 53 Q -
WorldVistAEHR/trunk/r/CONTROLLED_SUBSTANCES-PSD/PSDNTF.m
r613 r623 1 PSDNTF ;BIR/JPW-Transfer Green Sheet - From this NAOU ; 8/29/07 1:25pm 2 ;;3.0; CONTROLLED SUBSTANCES ;**8,56,63,66,64**;13 Feb 97;Build 33 3 ;**Y2K compliance**;display 4 digit year on va forms 4 I '$D(PSDSITE) D ^PSDSET Q:'$D(PSDSITE) 5 S OK=$S($D(^XUSEC("PSJ RNURSE",DUZ)):1,$D(^XUSEC("PSD NURSE",DUZ)):1,$D(^XUSEC("PSJ RPHARM",DUZ)):1,1:0) 6 I 'OK W $C(7),!!,?9,"** Please contact your Coordinator for access to",!,?12,"transfer narcotic orders.",!!,"PSJ RNURSE, PSD NURSE, or PSJ RPHARM security key required.",! K OK Q 7 W !!,"Transfer a Green Sheet from this NAOU" S PSDUZ=DUZ,PSDUZN=$P($G(^VA(200,PSDUZ,0)),"^") 8 ASKN ;ask transfer from naou 9 W ! K DA,DIC S DIC=58.8,DIC(0)="QEAZ",DIC("A")="Select Transfer from NAOU: " 10 S DIC("S")="I $P(^(0),""^"",3)=+PSDSITE,$S('$D(^(""I"")):1,'^(""I""):1,+^(""I"")>DT:1,1:0),$P(^(0),""^"",2)=""N"",'$P(^(0),""^"",7)" 11 D ^DIC K DIC G:Y<0 END S AOU=+Y,AOUN=$P(Y,"^",2) 12 GS ;select green sheet # 13 W ! K DA,DIC S DIC("A")="Select the Green Sheet #: ",DIC=58.81,DIC(0)="QEASZ",D="D" 14 S DIC("S")="I $P(^(0),""^"",11)=4!($P(^(0),U,11)=13),$P(^(0),""^"",18)=AOU",DIC("W")="W "" "",$P($G(^PSDRUG($P(^(0),U,5),0)),U),"" => "",$P($G(^DPT(+$P($G(^PSD(58.81,Y,9)),U),0)),U)" 15 D IX^DIC K DIC G:Y<0 END S PSDA=+Y 16 S STAT=+$P(Y(0),"^",11),PSDPN=$P(Y(0),"^",17),STATN="" I STAT S STATN=$P($G(^PSD(58.82,STAT,0)),"^") 17 S ORD=+$P(Y(0),"^",20),NAOU=+$P(Y(0),"^",18),NAOUN=$P($G(^PSD(58.8,NAOU,0)),"^"),PSDR=+$P(Y(0),"^",5),PSDRN=$P($G(^PSDRUG(PSDR,0)),"^") 18 S MFG=$P(Y(0),"^",13),LOT=$P(Y(0),"^",14),EXP=$P(Y(0),"^",15),QTY=+$P(Y(0),"^",6),PSDS=+$P(Y(0),"^",3) 19 S NBKU=$P($G(^PSD(58.8,+PSDS,1,+PSDR,0)),"^",8) 20 I $D(^PSD(58.81,PSDA,4)),+$P(^(4),"^",3) S QTY=+$P(^(4),"^",3) 21 I AOU'=NAOU W !!,"The Green Sheet # ",PSDPN," does not reside on ",AOUN,".",!,"Please select another Green Sheet.",! G ASKN 22 I '$D(^PSD(58.8,NAOU,1,PSDR,3,ORD,0)) W $C(7),!!,"There's no data on ",NAOUN," for Green Sheet # ",PSDPN,".",!,"Contact your Pharmacy Coordinator for assistance.",! G END 23 I STAT'=4,STAT'=13 W !!,"This Green Sheet has a status of "_$S(STATN]"":STATN,1:"UNKNOWN")_".",!,"Please contact your Pharmacy Coordinator for assistance.",! G END 24 I 'QTY W !!,"Previous transfer quantity was 0.",!,"Use option 'Transfer GS for PCA/Infusion Signed Out to Patient'",! G END 25 ASKT ;ask transfer to naou 26 W ! K DA,DIC S DIC=58.8,DIC(0)="QEAZ",DIC("A")="Select Transfer To NAOU: " 27 S DIC("S")="I $P(^(0),""^"",3)=+PSDSITE,$S('$D(^(""I"")):1,'^(""I""):1,+^(""I"")>DT:1,1:0),$P(^(0),""^"",2)=""N"",'$P(^(0),""^"",7)" 28 D ^DIC K DIC G:Y<0 END S NAOUT=+Y,NAOUTN=$P(Y,"^",2) 29 I NAOUT=AOU W !!,"You may not transfer a Green Sheet to your NAOU!",!,"Please select another NAOU.",!! G ASKT 30 ;*64 31 N PSDGS,PSDGSPTQ,PSDGSP0,PSDGSP9 32 S PSDGS=0 F S PSDGS=$O(^PSD(58.81,"D",PSDPN,PSDGS)) Q:'PSDGS D 33 .S PSDGSP0=$G(^PSD(58.81,PSDGS,0)),PSDGSP9=$G(^PSD(58.81,PSDGS,9)) 34 .I $P(PSDGSP0,"^",2)=17,$P(PSDGSP9,"^",1)]"" S PSDGSPTQ=$G(PSDGSPTQ)+$P(PSDGSP9,"^",3) 35 I $G(PSDGSPTQ) W !!,"Green Sheet "_PSDPN_" has dose(s) signed out to patient.",! 36 I QTY=1 S RQTY=1 W !,"Quantity to Transfer (",NBKU,"/1)",! G OK 37 QTY ; 38 W !,"Quantity to Transfer ("_NBKU_"/"_QTY_"): " R X:DTIME I '$T!(X="^")!(X="") S PSDOUT=1 W !!,"**** No action taken. ****",!! G END 39 ;I X'?1.6N!(X=0) W !!,"Enter a whole number between 1 and ",QTY,! G QTY 40 I +X'=X!(X>999999)!(X'>0)!(X?.E1"."4N.N) D G QTY 41 . W !!,"Enter a number between .01 and ",QTY,! 42 I X>QTY W $C(7),!!,"The quantity returned must not exceed "_QTY_"!",! G QTY 43 S RQTY=X 44 OK ;if perpetual NAOU and not ordered for patient 45 D:QTY=1&('$P($G(^PSD(58.81,PSDA,9)),U)) G:$G(PSDOUT) END 46 .W !,PSDRN," Current Balance: ",$P($G(^PSD(58.8,NAOU,1,PSDR,0)),U,4)," ",NBKU,! 47 .S DIR(0)="Y",DIR("A")="Is this a PCA syringe that has already been signed out for a patient",DIR("B")="Y",DIR("?")="If you answer no, your balance will be subtracted by one" D ^DIR K DIR I $D(DIRUT) S PSDOUT=1 Q 48 .Q:Y'=1 49 .S RQTY(1)=1 50 .S DIC="^DPT(",DIC(0)="AEMQ",DIC("A")="Scan/Enter Patient: " 51 .W ! D ^DIC K DIC I Y<1 S PSDOUT=1 W !!,"No action taken.",!! Q 52 .S PAT=+Y 53 ;ask ok to transfer 54 W ! K DA,DIR,DIRUT S DIR(0)="Y",DIR("A")="Are you sure",DIR("B")="NO" 55 S DIR("?",1)="Answer 'YES' to transfer this Green Sheet to another NAOU or",DIR("?")="answer 'NO' to leave the Green Sheet status active on your NAOU." 56 D ^DIR K DIR G:$D(DIRUT) END G:'Y GS 57 D NOW^%DTC S (RECD,Y)=+$E(%,1,12) X ^DD("DD") S RECDT=Y 58 COM ;complete at order level in 58.8 59 W !!,"Accessing ",PSDRN," information...",!! 60 S BQTY=$S($P($G(^PSD(58.8,NAOU,1,PSDR,3,ORD,0)),"^",22):$P(^(0),"^",22)-RQTY,1:QTY-RQTY) 61 W !!,"Updating your records now..." 62 ;update transaction file (58.81) 63 K DA,DIE,DR S DA=PSDA,DIE=58.81,DR="64////"_RECD_";65////"_PSDUZ_";66////"_NAOUT_";70////"_RQTY_";10////10;73////"_$G(PAT) D ^DIE K DA,DIE,DR 64 I $D(Y)!$D(DTOUT) W $C(7),!!,"** THIS GREEN SHEET HAS NOT BEEN TRANSFERRED **",!!,"The status remains "_STATN,! G END 65 ;update order 66 K DA,DIE,DR S DA=ORD,DA(1)=PSDR,DA(2)=NAOU,DIE="^PSD(58.8,"_DA(2)_",1,"_DA(1)_",3,",DR="10////10;22////"_BQTY D ^DIE K DA,DIE,DR 67 ;update naou bal 68 F L +^PSD(58.8,NAOU,1,PSDR,0):$S($G(DILOCKTM)>0:DILOCKTM,1:3) I Q 69 ;PSD*3*56;REMOVED CHECK FOR PATIENT ID 70 S:'$G(RQTY(1)) $P(^PSD(58.8,NAOU,1,PSDR,0),"^",4)=$P(^PSD(58.8,NAOU,1,PSDR,0),"^",4)-RQTY 71 W:$P($G(^PSD(58.8,NAOU,2)),U,5) !,PSDRN," Remaining Balance: ",$P($G(^PSD(58.8,NAOU,1,PSDR,0)),U,4)," ",NBKU,! 72 L -^PSD(58.8,NAOU,1,PSDR,0) 73 S STAT=$P($G(^PSD(58.81,PSDA,0)),"^",11) 74 W ?2,!,"*** The status of your Green Sheet #"_PSDPN_" is now",!,$S($P($G(^PSD(58.82,STAT,0)),"^")]"":$P(^(0),"^"),1:"UNKNOWN")_" ***",! 75 PRINT ;print 2321 76 W !!,"Number of copies of VA FORM 10-2321? " R NUM:DTIME I '$T!(NUM="^")!(NUM="") W !!,"No copies printed!!",!! Q 77 I NUM'?1N!(NUM=0) W !!,"Enter a whole number between 1 and 9",! G PRINT 78 S Y=RECD X ^DD("DD") S PSDYR=$P(Y,",",2),PSDYR=$E(PSDYR,1,4) 79 S (PG,PSDOUT)=0,REAS="",COMP=999,RECDT=$E(RECD,4,5)_"/"_$E(RECD,6,7)_"/"_PSDYR 80 I EXP S (EXP1,EXPD)=$$FMTE^XLFDT(EXP,"5D") S:'$P(EXP1,"/",2) EXPD=$P(EXP1,"/")_"/"_$P(EXP1,"/",3) S EXP=EXPD 81 D ^PSDGSRV2 82 END K %,%DT,%H,%I,AOU,AOUN,BQTY,COMP,D,DA,DIC,DIE,DIR,DIROUT,DIRUT,DR,DTOUT,DUOUT,EXP,EXP1,EXPD,LOT,MFG 83 K NAOU,NAOUN,NAOUT,NAOUTN,NBKU,NUM,OK,ORD,PG,PSDA,PSDOUT,PSDPN,PSDR,PSDRN,PSDS,PSDUZ,PSDUZN,PSDYR,QTY,REAS,RECD,RECDT,RQTY,STAT,STATN,X,Y 84 Q 1 PSDNTF ;BIR/JPW-Transfer Green Sheet - From this NAOU ; 1 Mar 98 2 ;;3.0; CONTROLLED SUBSTANCES ;**8,56,63,66**;13 Feb 97;Build 3 3 ;**Y2K compliance**;display 4 digit year on va forms 4 I '$D(PSDSITE) D ^PSDSET Q:'$D(PSDSITE) 5 S OK=$S($D(^XUSEC("PSJ RNURSE",DUZ)):1,$D(^XUSEC("PSD NURSE",DUZ)):1,$D(^XUSEC("PSJ RPHARM",DUZ)):1,1:0) 6 I 'OK W $C(7),!!,?9,"** Please contact your Coordinator for access to",!,?12,"transfer narcotic orders.",!!,"PSJ RNURSE, PSD NURSE, or PSJ RPHARM security key required.",! K OK Q 7 W !!,"Transfer a Green Sheet from this NAOU" S PSDUZ=DUZ,PSDUZN=$P($G(^VA(200,PSDUZ,0)),"^") 8 ASKN ;ask transfer from naou 9 W ! K DA,DIC S DIC=58.8,DIC(0)="QEAZ",DIC("A")="Select Transfer from NAOU: " 10 S DIC("S")="I $P(^(0),""^"",3)=+PSDSITE,$S('$D(^(""I"")):1,'^(""I""):1,+^(""I"")>DT:1,1:0),$P(^(0),""^"",2)=""N"",'$P(^(0),""^"",7)" 11 D ^DIC K DIC G:Y<0 END S AOU=+Y,AOUN=$P(Y,"^",2) 12 GS ;select green sheet # 13 W ! K DA,DIC S DIC("A")="Select the Green Sheet #: ",DIC=58.81,DIC(0)="QEASZ",D="D" 14 S DIC("S")="I $P(^(0),""^"",11)=4!($P(^(0),U,11)=13),$P(^(0),""^"",18)=AOU",DIC("W")="W "" "",$P($G(^PSDRUG($P(^(0),U,5),0)),U),"" => "",$P($G(^DPT(+$P($G(^PSD(58.81,Y,9)),U),0)),U)" 15 D IX^DIC K DIC G:Y<0 END S PSDA=+Y 16 S STAT=+$P(Y(0),"^",11),PSDPN=$P(Y(0),"^",17),STATN="" I STAT S STATN=$P($G(^PSD(58.82,STAT,0)),"^") 17 S ORD=+$P(Y(0),"^",20),NAOU=+$P(Y(0),"^",18),NAOUN=$P($G(^PSD(58.8,NAOU,0)),"^"),PSDR=+$P(Y(0),"^",5),PSDRN=$P($G(^PSDRUG(PSDR,0)),"^") 18 S MFG=$P(Y(0),"^",13),LOT=$P(Y(0),"^",14),EXP=$P(Y(0),"^",15),QTY=+$P(Y(0),"^",6),PSDS=+$P(Y(0),"^",3) 19 S NBKU=$P($G(^PSD(58.8,+PSDS,1,+PSDR,0)),"^",8) 20 I $D(^PSD(58.81,PSDA,4)),+$P(^(4),"^",3) S QTY=+$P(^(4),"^",3) 21 I AOU'=NAOU W !!,"The Green Sheet # ",PSDPN," does not reside on ",AOUN,".",!,"Please select another Green Sheet.",! G ASKN 22 I '$D(^PSD(58.8,NAOU,1,PSDR,3,ORD,0)) W $C(7),!!,"There's no data on ",NAOUN," for Green Sheet # ",PSDPN,".",!,"Contact your Pharmacy Coordinator for assistance.",! G END 23 I STAT'=4,STAT'=13 W !!,"This Green Sheet has a status of "_$S(STATN]"":STATN,1:"UNKNOWN")_".",!,"Please contact your Pharmacy Coordinator for assistance.",! G END 24 ASKT ;ask transfer to naou 25 W ! K DA,DIC S DIC=58.8,DIC(0)="QEAZ",DIC("A")="Select Transfer To NAOU: " 26 S DIC("S")="I $P(^(0),""^"",3)=+PSDSITE,$S('$D(^(""I"")):1,'^(""I""):1,+^(""I"")>DT:1,1:0),$P(^(0),""^"",2)=""N"",'$P(^(0),""^"",7)" 27 D ^DIC K DIC G:Y<0 END S NAOUT=+Y,NAOUTN=$P(Y,"^",2) 28 I NAOUT=AOU W !!,"You may not transfer a Green Sheet to your NAOU!",!,"Please select another NAOU.",!! G ASKT 29 I QTY=1 S RQTY=1 W !,"Quantity to Transfer (",NBKU,"/1)",! G OK 30 QTY ; 31 W !,"Quantity to Transfer ("_NBKU_"/"_QTY_"): " R X:DTIME I '$T!(X="^")!(X="") S PSDOUT=1 W !!,"**** No action taken. ****",!! G END 32 ;I X'?1.6N!(X=0) W !!,"Enter a whole number between 1 and ",QTY,! G QTY 33 I +X'=X!(X>999999)!(X'>0)!(X?.E1"."4N.N) D G QTY 34 . W !!,"Enter a number between .01 and ",QTY,! 35 I X>QTY W $C(7),!!,"The quantity returned must not exceed "_QTY_"!",! G QTY 36 S RQTY=X 37 OK ;if perpetual NAOU and not ordered for patient 38 D:QTY=1&('$P($G(^PSD(58.81,PSDA,9)),U)) G:$G(PSDOUT) END 39 .W !,PSDRN," Current Balance: ",$P($G(^PSD(58.8,NAOU,1,PSDR,0)),U,4)," ",NBKU,! 40 .S DIR(0)="Y",DIR("A")="Is this a PCA syringe that has already been signed out for a patient",DIR("B")="Y",DIR("?")="If you answer no, your balance will be subtracted by one" D ^DIR K DIR I $D(DIRUT) S PSDOUT=1 Q 41 .Q:Y'=1 42 .S RQTY(1)=1 43 .S DIC="^DPT(",DIC(0)="AEMQ",DIC("A")="Scan/Enter Patient: " 44 .W ! D ^DIC K DIC I Y<1 S PSDOUT=1 W !!,"No action taken.",!! Q 45 .S PAT=+Y 46 ;ask ok to transfer 47 W ! K DA,DIR,DIRUT S DIR(0)="Y",DIR("A")="Are you sure",DIR("B")="NO" 48 S DIR("?",1)="Answer 'YES' to transfer this Green Sheet to another NAOU or",DIR("?")="answer 'NO' to leave the Green Sheet status active on your NAOU." 49 D ^DIR K DIR G:$D(DIRUT) END G:'Y GS 50 D NOW^%DTC S (RECD,Y)=+$E(%,1,12) X ^DD("DD") S RECDT=Y 51 COM ;complete at order level in 58.8 52 W !!,"Accessing ",PSDRN," information...",!! 53 S BQTY=$S($P($G(^PSD(58.8,NAOU,1,PSDR,3,ORD,0)),"^",22):$P(^(0),"^",22)-RQTY,1:QTY-RQTY) 54 W !!,"Updating your records now..." 55 ;update transaction file (58.81) 56 K DA,DIE,DR S DA=PSDA,DIE=58.81,DR="64////"_RECD_";65////"_PSDUZ_";66////"_NAOUT_";70////"_RQTY_";10////10;73////"_$G(PAT) D ^DIE K DA,DIE,DR 57 I $D(Y)!$D(DTOUT) W $C(7),!!,"** THIS GREEN SHEET HAS NOT BEEN TRANSFERRED **",!!,"The status remains "_STATN,! G END 58 ;update order 59 K DA,DIE,DR S DA=ORD,DA(1)=PSDR,DA(2)=NAOU,DIE="^PSD(58.8,"_DA(2)_",1,"_DA(1)_",3,",DR="10////10;22////"_BQTY D ^DIE K DA,DIE,DR 60 ;update naou bal 61 F L +^PSD(58.8,NAOU,1,PSDR,0):$S($G(DILOCKTM)>0:DILOCKTM,1:3) I Q 62 ;PSD*3*56;REMOVED CHECK FOR PATIENT ID 63 S:'$G(RQTY(1)) $P(^PSD(58.8,NAOU,1,PSDR,0),"^",4)=$P(^PSD(58.8,NAOU,1,PSDR,0),"^",4)-RQTY 64 W:$P($G(^PSD(58.8,NAOU,2)),U,5) !,PSDRN," Remaining Balance: ",$P($G(^PSD(58.8,NAOU,1,PSDR,0)),U,4)," ",NBKU,! 65 L -^PSD(58.8,NAOU,1,PSDR,0) 66 S STAT=$P($G(^PSD(58.81,PSDA,0)),"^",11) 67 W ?2,!,"*** The status of your Green Sheet #"_PSDPN_" is now",!,$S($P($G(^PSD(58.82,STAT,0)),"^")]"":$P(^(0),"^"),1:"UNKNOWN")_" ***",! 68 PRINT ;print 2321 69 W !!,"Number of copies of VA FORM 10-2321? " R NUM:DTIME I '$T!(NUM="^")!(NUM="") W !!,"No copies printed!!",!! Q 70 I NUM'?1N!(NUM=0) W !!,"Enter a whole number between 1 and 9",! G PRINT 71 S Y=RECD X ^DD("DD") S PSDYR=$P(Y,",",2),PSDYR=$E(PSDYR,1,4) 72 S (PG,PSDOUT)=0,REAS="",COMP=999,RECDT=$E(RECD,4,5)_"/"_$E(RECD,6,7)_"/"_PSDYR 73 I EXP S (EXP1,EXPD)=$$FMTE^XLFDT(EXP,"5D") S:'$P(EXP1,"/",2) EXPD=$P(EXP1,"/")_"/"_$P(EXP1,"/",3) S EXP=EXPD 74 D ^PSDGSRV2 75 END K %,%DT,%H,%I,AOU,AOUN,BQTY,COMP,D,DA,DIC,DIE,DIR,DIROUT,DIRUT,DR,DTOUT,DUOUT,EXP,EXP1,EXPD,LOT,MFG 76 K NAOU,NAOUN,NAOUT,NAOUTN,NBKU,NUM,OK,ORD,PG,PSDA,PSDOUT,PSDPN,PSDR,PSDRN,PSDS,PSDUZ,PSDUZN,PSDYR,QTY,REAS,RECD,RECDT,RQTY,STAT,STATN,X,Y 77 Q -
WorldVistAEHR/trunk/r/CONTROLLED_SUBSTANCES-PSD/PSDNTT.m
r613 r623 1 PSDNTT ;BIR/JPW-Transfer Green Sheet - Receive this NAOU ; 6/25/07 12:16pm 2 ;;3.0; CONTROLLED SUBSTANCES ;**64**;13 Feb 97;Build 33 3 I '$D(PSDSITE) D ^PSDSET Q:'$D(PSDSITE) 4 S OK=$S($D(^XUSEC("PSJ RNURSE",DUZ)):1,$D(^XUSEC("PSD NURSE",DUZ)):1,1:0) 5 I 'OK W $C(7),!!,?9,"** Please contact your Coordinator for access to transfer",!,?12,"narcotic orders.",!!,"PSJ RNURSE or PSD NURSE security key required.",! K OK Q 6 I $P($G(^VA(200,DUZ,20)),U,4)']"" N XQH S XQH="PSD ESIG" D EN^XQH Q 7 W !!,"Receive a transferred Green Sheet into this NAOU" S PSDUZ=DUZ,PSDUZN=$P($G(^VA(200,PSDUZ,0)),"^") 8 ASKN ;ask transfer to naou 9 W ! K DA,DIC S DIC=58.8,DIC(0)="QEAZ",DIC("A")="Select Receive Transfer In NAOU: " 10 S DIC("S")="I $P(^(0),""^"",3)=+PSDSITE,$S('$D(^(""I"")):1,'^(""I""):1,+^(""I"")>DT:1,1:0),$P(^(0),""^"",2)=""N"",'$P(^(0),""^"",7)" 11 D ^DIC K DIC G:Y<0 END S AOU=+Y,AOUN=$P(Y,"^",2) 12 GS ;select green sheet # 13 W ! K DA,DIC S DIC("A")="Select the Green Sheet #: ",DIC=58.81,DIC(0)="QEASZ",D="D" 14 S DIC("S")="I $P(^(0),""^"",11)=10,'$P($G(^(7)),""^"",4),($P($G(^(7)),""^"",3)=AOU)!($P(^(0),""^"",18)=AOU)" 15 D IX^DIC K DIC G:Y<0 END S PSDA=+Y 16 S STAT=+$P(Y(0),"^",11),PSDPN=$P(Y(0),"^",17),STATN="" I STAT S STATN=$P($G(^PSD(58.82,STAT,0)),"^") 17 S ORD=+$P(Y(0),"^",20),PSDRG=+$P(Y(0),"^",5),PSDRGN=$P($G(^PSDRUG(PSDRG,0)),"^") 18 S NAOUF=+$P(Y(0),"^",18),NAOUFN=$P($G(^PSD(58.8,+NAOUF,0)),"^") 19 S PSDSP=$P($G(^PSD(58.8,NAOUF,1,PSDRG,3,ORD,0)),"^",14) 20 S MFG=$P(Y(0),"^",13),LOT=$P(Y(0),"^",14),EXP=$P(Y(0),"^",15),PSDS=+$P(Y(0),"^",3) 21 S QTY=+$P(Y(0),"^",6) I $D(^PSD(58.81,+PSDA,4)),+$P(^(4),"^",3) S QTY=+$P(^(4),"^",3) 22 S RQTY=+$P($G(^PSD(58.81,PSDA,7)),"^",7) 23 S NAOU=+$P($G(^PSD(58.81,PSDA,7)),"^",3),NAOUN=$P($G(^PSD(58.8,NAOU,0)),"^") 24 S PAT=+$P($G(^PSD(58.81,PSDA,9)),U) 25 I STAT'=10 W !!,"This Green Sheet has a status of "_$S(STATN]"":STATN,1:"UNKNOWN")_".",!,"Please contact your Pharmacy Coordinator for assistance.",! G END 26 ;*64 27 I RQTY=0 W !!,"Quantity of zero was transferred. Use menu option",!,"'Receive GS for PCA/Infusion Signed Out to Patient'",! G END 28 D CHK G:PSDOUT END N X,X1 D SIG^XUSESIG G:X1="" END 29 D ^PSDNTT1 30 END K %,%DT,%H,%I,AOU,AOUN,D,DA,DIC,DIE,DIK,DINUM,DIR,DIROUT,DIRUT,DLAYGO,DR,DTOUT,DUOUT,EXP,FLAG,JJ,LOT,MFG 31 K NAOU,NAOUF,NAOUFN,NAOUN,NAOUT,NAOUTN,OK,ORD,PAT,PSDA,PSDOUT,PSDPN,PSDREC,PSDRG,PSDRGN,PSDRN,PSDS,PSDSP,PSDT,PSDUZ,PSDUZN,QTY,RECD,RECDT,RQTY,STAT,STATN,X,Y 32 K XMDUZ,XMSUB,XMTEXT,XMY,^TMP("PSDNTMSG",$J) 33 Q 34 CHK ;check transfer to naou 35 S PSDOUT=0 W !!,?5,"The Green Sheet # ",PSDPN," and quantity of ",RQTY 36 I AOU'=NAOU W " was being transferred",!,?10,"*** from ",NAOUFN,!,?10,"*** to ",NAOUN,".",!!,$C(7),?5,"You are transferring it from ",NAOUFN,!,?10,"*** to ",AOUN,"." 37 I AOU=NAOU W " is being transferred ",!,?10,"*** from ",NAOUFN,!,?10,"*** to ",NAOUN,"." 38 W ! K DA,DIR,DIRUT S DIR(0)="Y",DIR("A")="Do you wish to complete this transfer",DIR("B")="NO" 39 S DIR("?",1)="Answer 'YES' to complete this Green Sheet transfer,",DIR("?")="answer 'NO' or '^' to quit without completing the transfer." 40 D ^DIR K DIR I 'Y!($D(DIRUT)) S PSDOUT=1 W !!,"Receive Green Sheet # ",PSDPN," transfer into another NAOU not completed.",!! Q 41 Q 1 PSDNTT ;BIR/JPW-Transfer Green Sheet - Receive this NAOU ; 22 Jun 93 2 ;;3.0; CONTROLLED SUBSTANCES ;;13 Feb 97 3 I '$D(PSDSITE) D ^PSDSET Q:'$D(PSDSITE) 4 S OK=$S($D(^XUSEC("PSJ RNURSE",DUZ)):1,$D(^XUSEC("PSD NURSE",DUZ)):1,1:0) 5 I 'OK W $C(7),!!,?9,"** Please contact your Coordinator for access to transfer",!,?12,"narcotic orders.",!!,"PSJ RNURSE or PSD NURSE security key required.",! K OK Q 6 I $P($G(^VA(200,DUZ,20)),U,4)']"" N XQH S XQH="PSD ESIG" D EN^XQH Q 7 W !!,"Receive a transferred Green Sheet into this NAOU" S PSDUZ=DUZ,PSDUZN=$P($G(^VA(200,PSDUZ,0)),"^") 8 ASKN ;ask transfer to naou 9 W ! K DA,DIC S DIC=58.8,DIC(0)="QEAZ",DIC("A")="Select Receive Transfer In NAOU: " 10 S DIC("S")="I $P(^(0),""^"",3)=+PSDSITE,$S('$D(^(""I"")):1,'^(""I""):1,+^(""I"")>DT:1,1:0),$P(^(0),""^"",2)=""N"",'$P(^(0),""^"",7)" 11 D ^DIC K DIC G:Y<0 END S AOU=+Y,AOUN=$P(Y,"^",2) 12 GS ;select green sheet # 13 W ! K DA,DIC S DIC("A")="Select the Green Sheet #: ",DIC=58.81,DIC(0)="QEASZ",D="D" 14 S DIC("S")="I $P(^(0),""^"",11)=10,'$P($G(^(7)),""^"",4),($P($G(^(7)),""^"",3)=AOU)!($P(^(0),""^"",18)=AOU)" 15 D IX^DIC K DIC G:Y<0 END S PSDA=+Y 16 S STAT=+$P(Y(0),"^",11),PSDPN=$P(Y(0),"^",17),STATN="" I STAT S STATN=$P($G(^PSD(58.82,STAT,0)),"^") 17 S ORD=+$P(Y(0),"^",20),PSDRG=+$P(Y(0),"^",5),PSDRGN=$P($G(^PSDRUG(PSDRG,0)),"^") 18 S NAOUF=+$P(Y(0),"^",18),NAOUFN=$P($G(^PSD(58.8,+NAOUF,0)),"^") 19 S PSDSP=$P($G(^PSD(58.8,NAOUF,1,PSDRG,3,ORD,0)),"^",14) 20 S MFG=$P(Y(0),"^",13),LOT=$P(Y(0),"^",14),EXP=$P(Y(0),"^",15),PSDS=+$P(Y(0),"^",3) 21 S QTY=+$P(Y(0),"^",6) I $D(^PSD(58.81,+PSDA,4)),+$P(^(4),"^",3) S QTY=+$P(^(4),"^",3) 22 S RQTY=+$P($G(^PSD(58.81,PSDA,7)),"^",7) 23 S NAOU=+$P($G(^PSD(58.81,PSDA,7)),"^",3),NAOUN=$P($G(^PSD(58.8,NAOU,0)),"^") 24 S PAT=+$P($G(^PSD(58.81,PSDA,9)),U) 25 I STAT'=10 W !!,"This Green Sheet has a status of "_$S(STATN]"":STATN,1:"UNKNOWN")_".",!,"Please contact your Pharmacy Coordinator for assistance.",! G END 26 D CHK G:PSDOUT END N X,X1 D SIG^XUSESIG G:X1="" END 27 D ^PSDNTT1 28 END K %,%DT,%H,%I,AOU,AOUN,D,DA,DIC,DIE,DIK,DINUM,DIR,DIROUT,DIRUT,DLAYGO,DR,DTOUT,DUOUT,EXP,FLAG,JJ,LOT,MFG 29 K NAOU,NAOUF,NAOUFN,NAOUN,NAOUT,NAOUTN,OK,ORD,PAT,PSDA,PSDOUT,PSDPN,PSDREC,PSDRG,PSDRGN,PSDRN,PSDS,PSDSP,PSDT,PSDUZ,PSDUZN,QTY,RECD,RECDT,RQTY,STAT,STATN,X,Y 30 K XMDUZ,XMSUB,XMTEXT,XMY,^TMP("PSDNTMSG",$J) 31 Q 32 CHK ;check transfer to naou 33 S PSDOUT=0 W !!,?5,"The Green Sheet # ",PSDPN," and quantity of ",RQTY 34 I AOU'=NAOU W " was being transferred",!,?10,"*** from ",NAOUFN,!,?10,"*** to ",NAOUN,".",!!,$C(7),?5,"You are transferring it from ",NAOUFN,!,?10,"*** to ",AOUN,"." 35 I AOU=NAOU W " is being transferred ",!,?10,"*** from ",NAOUFN,!,?10,"*** to ",NAOUN,"." 36 W ! K DA,DIR,DIRUT S DIR(0)="Y",DIR("A")="Do you wish to complete this transfer",DIR("B")="NO" 37 S DIR("?",1)="Answer 'YES' to complete this Green Sheet transfer,",DIR("?")="answer 'NO' or '^' to quit without completing the transfer." 38 D ^DIR K DIR I 'Y!($D(DIRUT)) S PSDOUT=1 W !!,"Receive Green Sheet # ",PSDPN," transfer into another NAOU not completed.",!! Q 39 Q -
WorldVistAEHR/trunk/r/CONTROLLED_SUBSTANCES-PSD/PSDSITE.m
r613 r623 1 PSDSITE 2 ;;3.0; CONTROLLED SUBSTANCES ;**65**;13 Feb 97;Build 5 3 SITE 4 K DIC,DLAYGO S DIC="^PS(59.4,",DLAYGO=59.4,DIC(0)="QEAL",D="B",DZ="??"5 6 7 END 8 9 10 LOW 11 12 13 14 15 16 17 18 19 HIGH 20 21 22 23 24 25 26 27 28 29 MSG 30 31 32 33 LAST 34 35 36 37 38 39 40 MSG1 41 42 43 LAST1 44 45 46 47 MSG2 48 49 50 1 PSDSITE ;BIR/JPW,LTL-Site Parameters for CS ; 3 May 95 2 ;;3.0; CONTROLLED SUBSTANCES ;;13 Feb 97 3 SITE ;entry for selecting inpatient sites in file 59.4 4 K DIC,DLAYGO S (DIC,DLAYGO)="^PS(59.4,",DIC(0)="QEAL",D="B",DZ="??" 5 D DQ^DICQ K D,DZ W ! D ^DIC K DIC G:Y<0 END 6 K DA,DIE,DR S DIE=59.4,DA=+Y,DR="31"_"Is "_$P(Y,U,2)_" selectable for Controlled Subs" W ! D ^DIE K DIE 7 END K DA,DIC,DIE,DLAYGO,DR,DTOUT,DUOUT,X,Y 8 Q 9 ; 10 LOW ;if auto generate, check low range for numbers 11 I '$D(X) S PSDFLAG=1 Q 12 K PSD,PSDFLAG,PSDL F PSD=0:0 S PSD=$O(^PSD(58.8,PSD)) Q:'PSD I $D(^PSD(58.8,PSD,0)),$D(^(2)),$P(^(2),"^") D 13 .I +$P(^PSD(58.8,PSD,2),"^",2),+$P(^(2),"^",3) S PSDL(+PSD)="" 14 I $O(PSDL(0)) F PSD=0:0 S PSD=+$O(PSDL(PSD)) Q:'PSD D 15 .I X'<$P($G(^PSD(58.8,PSD,2)),"^",2),(X'>$P($G(^(2)),"^",3)),PSD'=DA D MSG S PSDFLAG=1 Q 16 W:$D(PSDFLAG) " Select another range.",! K PSD,PSDL 17 Q 18 ; 19 HIGH ;validates high range for dispensing numbers 20 I '$D(X) S PSDFLAG=1 Q 21 K PSD,PSDFLAG,PSDH,PSDL F PSD=0:0 S PSD=$O(^PSD(58.8,PSD)) Q:'PSD I $D(^PSD(58.8,PSD,0)),$D(^(2)),$P(^(2),"^") D 22 .I +$P(^PSD(58.8,PSD,2),"^",2) S PSDL(+$P(^(2),"^",2))=PSD 23 S PSDL=+$P($G(^PSD(58.8,DA,2)),"^",2),PSDH=+$O(PSDL(PSDL)) I PSDH S PSD=+$P(PSDL(PSDH),"^") 24 I X'>PSDL W !!,"High dispensing # must be larger than your low dispensing # "_PSDL_".",!! S PSDFLAG=1 Q 25 I PSDH,X'<PSDH D MSG S PSDFLAG=1 26 W:$D(PSDFLAG) " Select another range.",! K PSD,PSDH,PSDL 27 Q 28 ; 29 MSG ;prints message if range already in use 30 W $C(7),!!,?12," => Dispensing Site "_$S($P(^PSD(58.8,PSD,0),"^")]"":$P(^(0),"^"),1:"NAME MISSING")_" <=",!,"has set aside the range "_$P($G(^PSD(58.8,PSD,2)),"^",2)_" through "_$P($G(^(2)),"^",3)_"." 31 Q 32 ; 33 LAST ;checks range for 'last dispensed' 34 I '$D(X) S PSDFLAG=1 Q 35 I $D(PSDEN) D LAST1 K LOW,HIGH,PSDCHK Q 36 I X<$P($G(^PSD(58.8,DA,2)),"^",2) D MSG1 S PSDFLAG=1 Q 37 I X>$P($G(^PSD(58.8,DA,2)),"^",3) D MSG1 S PSDFLAG=1 38 Q 39 ; 40 MSG1 ;prints message if not in dispensing range 41 W $C(7),!!,"Last number dispensed must be within the range "_$P($G(^PSD(58.8,DA,2)),"^",2)_" to "_$S($P($G(^(2)),"^",3):$P($G(^(2)),"^",3),1:999999999)_".",! 42 Q 43 LAST1 ;checks LOW/HIGH range and LAST dispensed 44 I X<LOW D MSG2 S PSDFLAG=1 Q 45 I X>HIGH D MSG2 S PSDFLAG=1 46 Q 47 MSG2 ;prints msg if not in dispensing range 48 S PSDCHK=1 49 W $C(7),!!,"Last number dispensed must be within the range ",LOW," to ",HIGH,".",! 50 Q
Note:
See TracChangeset
for help on using the changeset viewer.