source: WorldVistAEHR/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSODACT.m@ 1093

Last change on this file since 1093 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR
File size: 3.4 KB
RevLine 
[613]1PSODACT ;BHAM ISC/JrR - CREATE DUE ANSWER SHEET FROM ACTION PROFILE ; 11/18/92 18:58
2 ;;7.0;OUTPATIENT PHARMACY;**2**;DEC 1997
3 Q
4ENSAVE ;Enter here from PSOSD0 to store info about each DUE RX
5 ;as Action Profile is printing. Needs RXNODE=NODE '0' OF RXN,RXN
6 S PSOQDRG=$P(RXNODE,"^",6),PSOQDFN=$P(RXNODE,"^",2)
7 I $D(^PS(50.073,"AD",PSOQDRG)),('$P(RXNODE,"^",15)!($P(RXNODE,"^",15)=5)) F PSOQ=0:0 S PSOQ=$O(^PS(50.073,"AD",PSOQDRG,PSOQ)) Q:'PSOQ D
8 .I $P(^PS(50.073,PSOQ,0),"^",2),$P(^(0),"^",3) F DIV=0:0 S DIV=$O(^PS(50.073,PSOQ,3,DIV)) Q:'DIV I $P(^PS(50.073,PSOQ,3,DIV,0),"^")=$G(PSOSITE) D STORE
9 K PSOQ,PSOQDRG,PSOQDFN,DIV
10 QUIT
11 ;return to ^PSOSD0
12 ;
13STORE S ^TMP("PSOD",$J,RXN,PSOQDRG,PSOQ,5)=$P(RXNODE,"^",4)
14 S ^TMP("PSOD",$J,RXN,PSOQDRG,PSOQ,8)=PSOQDFN
15 Q
16 ;
17ENSTUFF ;Enter here from PSOSD Action Profile
18 ;Print an Answer sheet for DUE RXs stored at ENSAVE above
19 NEW I,RXN
20 Q:'$D(^TMP("PSOD",$J))
21 F RXN=0:0 S RXN=$O(^TMP("PSOD",$J,RXN)) Q:'RXN F PSOQDRG=0:0 S PSOQDRG=$O(^TMP("PSOD",$J,RXN,PSOQDRG)) Q:'PSOQDRG F PSOQ=0:0 S PSOQ=$O(^TMP("PSOD",$J,RXN,PSOQDRG,PSOQ)) Q:'PSOQ D PRINT
22 K ^TMP("PSOD",$J) W:'$D(PSONOPG) @IOF
23 K PSOQDRG,PSOQ,PSA,PIECE,FLAG,I,PSOQPHYS,DFN,SSN,PSIGN,PSOQL
24 K PSOQDFN,PSOQM,PSOQSSN,PSQNUM,PSOQN,PSOQNUM,PSQ,PSTXT,PSWRAP,PSMARG
25 QUIT
26 ;return to ^PSOSD
27 ;
28SET ;This code is not being executed at this time.
29 D NEW S PSA=+Y
30 S $P(^PS(50.0731,PSA,0),"^",2,4)=PSOQ_"^"_PSOQDRG_"^"_RXN
31 F PIECE=5,8 S $P(^PS(50.0731,PSA,0),"^",PIECE)=^TMP("PSOD",$J,RXN,PSOQDRG,PSOQ,PIECE)
32MOVE S FLAG=0
33 F I=0:0 S I=$O(^PS(50.073,PSOQ,2,I)) Q:'I S:$D(^PS(50.0732,$P(^(I,0),"^",2),0)) ^PS(50.0731,PSA,1,I,0)=^PS(50.073,PSOQ,2,I,0),$P(^PS(50.0732,$P(^(0),"^",2),0),"^",7)=1,FLAG=1
34 S:FLAG $P(^PS(50.073,PSOQ,0),"^",4)=1,^PS(50.0731,PSA,1,0)="^50.07311IA^"_$P(^PS(50.073,PSOQ,2,0),"^",3,4)
35 S DIK="^PS(50.0731,",DA=PSA D IX^DIK K DIK,DA
36 Q
37 ;
38NEW ;laygo into the DUE Answer file
39 L +^PS(50.0731,0):20
40 S X=$P(^PS(50.0731,0),"^",3)
41LOOP S X=X+1 G:$D(^PS(50.0731,X)) LOOP L
42 K DIC,DD,DO S DIC="^PS(50.0731,",DIC(0)="XL",DIC("DR")="6///NOW",DLAYGO=50.0731,DINUM=X D FILE^DICN
43 K DIC,DLAYGO,DINUM
44 L -^PS(50.0731,0)
45 Q:$P(Y,"^",3)
46 G NEW
47 ;
48PRINT ;prints DUE Questionnaire
49 W @IOF,!!,@$S($G(PSORM)=0:"?25",1:"?52"),"***** Due Answer Sheet *****"
50 W !!,"SEQ. Number: _______________",?($X+3),"Questionnaire: "_$P(^PS(50.073,PSOQ,0),"^"),@$S($G(PSORM)=0:"!",1:"?$X+3"),"Drug: "_$P(^PSDRUG(PSOQDRG,0),"^"),@$S($G(PSORM)=0:"?45",1:"?109"),"Rx #: "_$P(^PSRX(RXN,0),"^")
51 S PSOQPHYS=$P($G(^VA(200,+$P(^PSRX(RXN,0),"^",4),0)),"^")
52 W !!,"Rx Provider: ",$E(PSOQPHYS,1,20)
53 S PSOQDFN=^TMP("PSOD",$J,RXN,PSOQDRG,PSOQ,8)
54 W ?($X+3),"Patient: ",$P(^DPT(PSOQDFN,0),"^"),@$S($G(PSORM)=0:"!",1:"?$X+3"),"ID#: "_VA("PID"),?($X+3),"Section: ______________"
55 W @$S($G(PSORM)=0:"?$X+3",1:"?109"),"Date: "
56 S Y=DT D DT^DIQ
57QOUT ;Enter here from ^PSODUE to print questions for Questionaire
58 K PSOQL S $P(PSOQL,"-",$S($G(PSORM)=0:80,1:IOM))="" W !,PSOQL
59 I $O(^PS(50.073,PSOQ,"N",0)) D NARATV,^DIWW K DIWF,DIWL,DIWR
60 S PSIGN=0
61 I $O(^PS(50.073,PSOQ,2,0)) F PSOQN=0:0 S PSOQN=$O(^PS(50.073,PSOQ,2,PSOQN)) Q:'PSOQN S PSIGN=1,PSOQM=^(PSOQN,0) D:$P(PSOQM,"^",2)
62 .S PSQNUM=+PSOQM,PSQ=$P(^PS(50.0732,$P(PSOQM,"^",2),0),"^") D WRAP^PSODEDT W !?($L(PSQNUM)+2),"Answer: ",! I $Y>(IOSL-7) W @IOF
63 W:PSIGN ?(IOM-40),"Signature: __________________________",!
64 Q
65NARATV K ^UTILITY($J,"W") S DIWL=4,DIWR=$S($G(PSORM)=0:80,1:IOM),DIWF="WN" F PSOQN=0:0 S PSOQN=$O(^PS(50.073,PSOQ,"N",PSOQN)) Q:'PSOQN S X=^(PSOQN,0) D ^DIWP
66 Q
Note: See TracBrowser for help on using the repository browser.