source: WorldVistAEHR/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOHCPRS.m@ 975

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

initial load of WorldVistAEHR

File size: 3.5 KB
Line 
1PSOHCPRS ;BIR/RTR-Put CHCS message in Pending File and process ;07/02/02
2 ;;7.0;OUTPATIENT PHARMACY;**111**;DEC 1997
3 ;External reference to ^DG(40.8 supported by DBIA 728
4 ;External reference to ^SC( supported by DBIA 2675
5 ;
6ADD ;Add CHCS message to Outpatient Pending Orders file
7 N PSOHQ,PSOHQT,PSOCPEND,PSOHINI,PSOHINLO
8 S (PSOHINI,PSOHINLO)=0 D
9 .I $G(PSOHY("LOC")) S PSOHINLO=$P($G(^SC(PSOHY("LOC"),0)),"^",4) I PSOHINLO Q
10 .I $G(PSOHY("LOC")) S PSOHINI=$P($G(^SC(PSOHY("LOC"),0)),"^",15)
11 .I '$G(PSOHINI) S PSOHINI=$O(^DG(40.8,0))
12 .S PSOHINLO=+$$SITE^VASITE(PSOHINI)
13 I +$G(PSOHINLO)<0 S PSOEXMS="Unable to derive Institution from CLinic." D NAK^PSOHLEXC Q
14 K DD,DO,DIC S X=PSOHY("CHNUM"),DIC="^PS(52.41,",DIC(0)="L"
15 S:$G(PSOHY("PICK"))="" PSOHY("PICK")="W"
16 S DIC("DR")="4////"_$G(PSOHY("ENTER"))_";5////"_PSOHY("PROV")_";6////"_$G(PSOHY("SDT"))_";8////"_PSOHY("ITEM")_";11////"_PSOHY("DRUG")_";12////"_$G(PSOHY("QTY"))_";13////"_$G(PSOHY("REF"))
17 D FILE^DICN K DD,DIC,DO I Y<0 S PSOEXMS="Unable to add order to Pending file." D NAK^PSOHLEXC Q
18 S PSOCPEND=+Y
19 S $P(^PS(52.41,PSOCPEND,0),"^",2)=PSOHY("PAT"),$P(^(0),"^",3)=PSOHY("OCC"),$P(^(0),"^",12)=$G(PSOHY("EDT")),$P(^(0),"^",13)=PSOHY("LOC")
20 S $P(^PS(52.41,PSOCPEND,0),"^",14)=$G(PSOHY("PRIOR")),$P(^(0),"^",17)=$G(PSOHY("PICK"))
21 S $P(^PS(52.41,PSOCPEND,"EXT"),"^")=PSOHY("CHNUM"),$P(^("EXT"),"^",2)=0,$P(^("EXT"),"^",3)=PSOHY("EXAPP")
22 N DA,DIK S DA=PSOCPEND,DIK="^PS(52.41,",DIK(1)="114^C" D EN1^DIK
23 I $O(PSOHY("PRCOM",0)) D I PSOHQT S ^PS(52.41,PSOCPEND,3,0)="^^"_PSOHQT_"^"_PSOHQT_"^"_DT_"^"
24 .S PSOHQ="",PSOHQT=0 F S PSOHQ=$O(PSOHY("PRCOM",PSOHQ)) Q:PSOHQ="" I $G(PSOHY("PRCOM",PSOHQ))'="" S PSOHQT=PSOHQT+1,^PS(52.41,PSOCPEND,3,PSOHQT,0)=$G(PSOHY("PRCOM",PSOHQ))
25 I $O(PSOHY("SIG",0)) D I PSOHQT S ^PS(52.41,PSOCPEND,"SIG",0)="^52.4124A^"_PSOHQT_"^"_PSOHQT
26 .S PSOHQ="",PSOHQT=0 F S PSOHQ=$O(PSOHY("SIG",PSOHQ)) Q:PSOHQ="" I $G(PSOHY("SIG",PSOHQ))'="" S PSOHQT=PSOHQT+1,^PS(52.41,PSOCPEND,"SIG",PSOHQT,0)=$G(PSOHY("SIG",PSOHQ))
27 S $P(^PS(52.41,PSOCPEND,"INI"),"^")=$G(PSOHINLO)
28 ;Cross references not set yet preventing Pharmacy from finishing order
29 D EN^PSOHLSNC(PSOCPEND,"SN","IP")
30 ;Just set to DC, don't delete because 52.41 entry would be re-used
31 ;I '$P($G(^PS(52.41,PSOCPEND,"EXT")),"^",2) S DA=PSOCPEND,DIK="^PS(52.41," D ^DIK K DIK,DA S PSOEXMS="Unable to send CHCS order to CPRS." D NAK^PSOHLEXC Q
32 I '$P($G(^PS(52.41,PSOCPEND,"EXT")),"^",2) D S $P(^PS(52.41,PSOCPEND,0),"^",3)="DC" S PSOEXMS="Unable to send CHCS order to CPRS." D NAK^PSOHLEXC Q
33 .;x-ref shouldn't be set, but we'll kill them just in case
34 .K ^PS(52.41,"AOR",$P(^PS(52.41,PSOCPEND,0),"^",2),+$P($G(^("INI")),"^"),PSOCPEND),^PS(52.41,"AD",$P(^PS(52.41,PSOCPEND,0),"^",12),+$P($G(^("INI")),"^"),PSOCPEND)
35 .K ^PS(52.41,"ACL",+$P(^PS(52.41,PSOCPEND,0),"^",13),$P(^(0),"^",12),PSOCPEND),^PS(52.41,"AQ",+$P($G(^PS(52.41,PSOCPEND,0)),"^",21),PSOCPEND)
36 .S $P(^PS(52.41,PSOCPEND,4),"^")="External order, unable to successfully transmit to CPRS."
37 ;Successful transmission to CPRS
38 S DA=PSOCPEND,DIK="^PS(52.41," D IX^DIK
39 Q
40SIGS ;
41 N PSOHZZZ,PSOHZZZZ
42 S PSOHZZZ=1,PSOHZZZZ=""
43 F S PSOHZZZZ=$O(^PS(52.41,ORD,"SIG",PSOHZZZZ)) Q:PSOHZZZZ="" I $D(^(PSOHZZZZ,0)) S SIG(PSOHZZZ)=$G(^(0)),PSOHZZZ=PSOHZZZ+1
44 I $O(PSONEW("SIG",""))'="" S PSOHZZZZ="" F S PSOHZZZZ=$O(PSONEW("SIG",PSOHZZZZ)) Q:PSOHZZZZ="" S SIG(PSOHZZZ)=$G(PSONEW("SIG",PSOHZZZZ)),PSOHZZZ=PSOHZZZ+1
45 I $O(PSONEW("SIG",""))'="" Q
46 I $O(PRC(""))'="" S PSOHZZZZ="" F S PSOHZZZZ=$O(PRC(PSOHZZZZ)) Q:PSOHZZZZ="" I $D(PRC(PSOHZZZZ)) S SIG(PSOHZZZ)=$G(PRC(PSOHZZZZ)),PSOHZZZ=PSOHZZZ+1
47 Q
Note: See TracBrowser for help on using the repository browser.