source: FOIAVistA/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSODLKP.m@ 1607

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

initial load of FOIAVistA 6/30/08 version

File size: 4.5 KB
Line 
1PSODLKP ;BHAM ISC/JrR - CREATE/EDIT DUE ANSWER FILE ENTRY ; 11/17/92 10:19
2 ;;7.0;OUTPATIENT PHARMACY;**268**;DEC 1997;Build 9
3 Q
4CREATE ;Create a new DUE ANSWER entry
5 W !!
6 D NEW
7 S PSA=+Y W !,"SEQUENCE NUMBER: ",PSA
8 S DIC="^PSRX(",DIC("A")="RX #: ",DIC(0)="QEAMZ"
9 D ^DIC K DIC
10 I $D(DUOUT)!$D(DTOUT) D DELETE G EXIT
11 S RXN=+Y,RX0=$S($D(Y(0)):Y(0),1:""),RXM=$S($D(Y(0,0)):Y(0,0),1:"")
12 D STUFF,QAIRE
13 I '$D(PSQA) D DELETE G EXIT
14 D DIE
15EXIT K CNT,D,DA,DIC,DIE,DIK,DINUM,DIR,DIRUT,DIROUT,DLAYGO,DR,DTOUT,DUOUT
16 K DZ,FLAG,I,K,L,LL,PZPOP,PSA,PSDFN,PSDIG,PSDRUG,PSHI,PSLEN,PSLO,PSMARG
17 K PSPROV,PSQ,PSQA,PSQN,PSQNUM,PSQP,PSTXT,PSTYP,PSWRAP,RX0,RXM,RXN,X,Y
18 K PSKIP,PID
19 W !! Q
20 ;
21DIE ;Enter here from PSODLKP,PSODEDT. Edit the DUE Answer sheet
22 S DIE="^PS(50.0731,",DA=PSA,DR="[PSOD DUE EDIT]" L +^PS(50.0731,DA):$S(+$G(^DD("DILOCKTM"))>0:+^DD("DILOCKTM"),1:3) I '$T W !,"Entry is being edited by another user. Try Later!" K DA,DR,DIE,PSA Q
23 D ^DIE K DIE,DR L -^PS(50.0731,DA) K DA
24GETQUES F PSQNUM=0:0 S PSQNUM=$O(^PS(50.0731,PSA,1,"B",PSQNUM)) Q:'PSQNUM S PSQN=$O(^(PSQNUM,0)),PSQP=$P(^PS(50.0731,PSA,1,PSQN,0),"^",2) I $D(^PS(50.0732,PSQP,0)) S PSQ=^(0) D ASK Q:PZPOP
25 Q
26ASK S PZPOP=0
27 D WRAP^PSODEDT
28 S PSTYP=$S($P(PSQ,"^",2):$P(PSQ,"^",2),1:1),PSLO=$S($P(PSQ,"^",3)]"":$P(PSQ,"^",3),1:-999),PSHI=$S($P(PSQ,"^",4)]"":$P(PSQ,"^",4),1:999)
29 S PSDIG=$S($P(PSQ,"^",5)]"":$P(PSQ,"^",5),1:2),PSLEN=$S($P(PSQ,"^",6)]"":$P(PSQ,"^",6),1:70)
30 S DIR("??")="^D QUES2^PSODEDT",DIR("A")=" ANSWER: "
31 S DIR(0)=$S(PSTYP=1:"S^Y:YES;N:NO;U:UNKNOWN",PSTYP=2:"F^1:"_PSLEN,PSTYP=3:"N^"_PSLO_":"_PSHI_":"_PSDIG,1:"Y")
32 S $P(DIR(0),"^")=$P(DIR(0),"^")_"AO"
33 K DIR("B")
34 I $D(^PS(50.0731,PSA,1,PSQN,1)),^(1)]"" S DIR("B")=^(1)
35 D ^DIR K DIR
36 I $D(DUOUT)!$D(DTOUT) S PZPOP=1 Q
37 S X=$S($D(Y(0)):Y(0),1:Y)
38 S ^PS(50.0731,PSA,1,PSQN,1)=X
39 Q
40 ;
41NEW L +^PS(50.0731,0):$S(+$G(^DD("DILOCKTM"))>0:+^DD("DILOCKTM"),1:3) E W $C(7),!,"Trying to Lock ^PS(50.0731,0)" G NEW
42 S X=$P(^PS(50.0731,0),"^",3)
43LOOP S X=X+1 G:$D(^PS(50.0731,X)) LOOP
44 K DIC,DD,DO S DIC="^PS(50.0731,",DIC(0)="XL",DIC("DR")="6///NOW"_$S($D(DUZ)#2:";5////"_DUZ,1:""),DLAYGO=50.0731,DINUM=X D FILE^DICN L -^PS(50.0731,0)
45 K DIC,DLAYGO,DINUM
46 Q:$P(Y,"^",3)
47 G NEW
48 ;
49QAIRE K PSQA,DA S DIR(0)="50.0731,1" D ^DIR K DIR
50 Q:$D(DUOUT)!$D(DTOUT)
51 I 'Y W !,$C(7)," REQUIRED!" G QAIRE
52 I $S('$D(^PS(50.073,+Y,2,0)):1,'$O(^(0)):1,1:0) W !!," Sorry, that Questionnaire is incomplete.",!," Please review it before proceeding!" Q
53 S PSQA=+Y,$P(^PS(50.0731,PSA,0),"^",2)=PSQA
54MOVE S FLAG=0
55 F I=0:0 S I=$O(^PS(50.073,PSQA,2,I)) Q:'I S:$D(^PS(50.0732,$P(^(I,0),"^",2),0)) ^PS(50.0731,PSA,1,I,0)=^PS(50.073,PSQA,2,I,0),$P(^PS(50.0732,$P(^(0),"^",2),0),"^",7)=1,FLAG=1
56 S:FLAG $P(^PS(50.073,PSQA,0),"^",4)=1,^PS(50.0731,PSA,1,0)="^50.07311IA^"_$P(^PS(50.073,PSQA,2,0),"^",3,4)
57 ;S DIK="^PS(50.0731,"_PSA_",1,",DA(1)=PSA D IXALL^DIK K DIK,DA
58 S DIK="^PS(50.0731,",DA=PSA D IX^DIK K DIK,DA
59 K FLAG
60 Q
61STUFF K PSKIP
62 Q:RXN<1
63 S PSKIP=""
64 S PSDRUG=$P(RX0,"^",6),PSPROV=$P(RX0,"^",4),PSDFN=$P(RX0,"^",2)
65 S DIE="^PS(50.0731,",DA=PSA,DR="2////"_PSDRUG_";3////"_RXN_";4////"_PSPROV_";7////"_PSDFN_";10////"_PSOSITE D ^DIE K DIE,DA,DR
66 S Y=PSDRUG,C=$P(^DD(50.0731,2,0),"^",2) D Y^DIQ W:Y]"" !,"DRUG: ",Y
67 S Y=PSDFN,C=$P(^DD(50.0731,7,0),"^",2) D Y^DIQ W:Y]"" !,"PATIENT: ",Y
68 Q:'$D(^PS(50.073,"AD",PSDRUG))
69 S CNT=0 F L=0:0 S L=$O(^PS(50.073,"AD",PSDRUG,L)) Q:'L I $P(^PS(50.073,L,0),"^",3) S CNT=CNT+1,LL=L
70 I CNT=1 S DIR("B")=$P(^PS(50.073,LL,0),"^") Q
71 W !?5,"This Drug requires the following Active Questionnaires:"
72 S DIC="^PS(50.073,",DIC(0)="QEM",D="B",DZ="??",DIC("S")="I $D(^PS(50.073,""AD"",PSDRUG,Y))&($P(^PS(50.073,Y,0),""^"",3))" D DQ^DICQ K DIC,D,DZ
73 Q
74DELETE W $C(7),!,"Deleting SEQUENCE NUMBER: ",PSA
75 S DA=PSA,DIK="^PS(50.0731," D ^DIK
76 Q
77QUES2 Q I PSTYP=1 W !!,?5,"Enter Y for YES, N for NO, U for UNKNOWN."
78 I PSTYP=2 W !!,?5,"Enter a FREE TEXT answer from 1 to ",PSLEN," characters."
79 I PSTYP=3 W !!,?5,"Enter a number between ",PSLO," and ",PSHI,!,?5,"with a maximum of ",PSDIG," decimal digits."
80 W !?5,"Enter '^' to bypass."
81 D WRAP^PSODEDT
82 Q
83CHECK ;CHECK FOR DRUG MATCH FROM ORDER ENTRY
84 F PSODDRG=0:0 S PSODDRG=$O(^PS(50.073,"AD",PSODDRG)) Q:'PSODDRG I PSODDRG=$P(^PSRX(PSONEW("IRXN"),0),"^",6) D CHECK1
85 Q
86CHECK1 F PSOST=0:0 S PSOST=$O(^PS(50.073,"AD",PSODDRG,PSOST)) Q:'PSOST S PSOSTE=$P(^PS(50.073,PSOST,0),"^",5) Q:PSOSITE'=PSOSTE S RXN=PSONEW("IRXN"),RX0=^PSRX(RXN,0) D CREATE1,EXIT
87 Q
88CREATE1 ;Create a new DUE ANSWER entry
89 W !!
90 D NEW
91 S PSA=+Y W !,"SEQUENCE NUMBER: ",PSA
92 S (RX0,RXM)=$S($D(^PSRX(RXN,0)):^(0),1:"")
93 D STUFF,QAIRE
94 I '$D(PSQA) D DELETE G EXIT
95 D DIE
96 Q
Note: See TracBrowser for help on using the repository browser.