57 lines
3.1 KiB
Mathematica
57 lines
3.1 KiB
Mathematica
PSOPOST3 ;BIR/SAB-index AD cross reference on login date field ;07/29/96
|
|
;;7.0;OUTPATIENT PHARMACY;**7,15,25,30,77**;DEC 1997
|
|
;
|
|
;Reference to ^DD(55,0,"P") and ^DD(55,0,"PS") is supported by IA #2752
|
|
;Reference to setting ^DD(52,0,"ID",6) supported by DBIA #2852
|
|
;Reference to DIU2 supported by DBIA #10014
|
|
;
|
|
K ^PS(52.41,"AD")
|
|
D BMES^XPDUTL("Indexing 'AD' cross reference...")
|
|
F PAT=0:0 S PAT=$O(^PS(52.41,"AOR",PAT)) Q:'PAT F INST=0:0 S INST=$O(^PS(52.41,"AOR",PAT,INST)) Q:'INST D
|
|
.F DA=0:0 S DA=$O(^PS(52.41,"AOR",PAT,INST,DA)) Q:'DA D
|
|
..I '$P(^PS(52.41,DA,0),"^",12) D NOW^%DTC S $P(^PS(52.41,DA,0),"^",12)=%
|
|
..S DIK="^PS(52.41,",DIK(1)=15 D EN1^DIK W "."
|
|
K PAT,INST,DA,DIK,DIC,X,Y,%,%H,%I
|
|
Q
|
|
SUS ;Deleting invalid "AQ" cross references
|
|
; Patch PSO*7*15 post init
|
|
D BMES^XPDUTL("Indexing 'AQ' cross reference...")
|
|
N PSOD,PSOP,PSOIN
|
|
F PSOD=0:0 S PSOD=$O(^PS(52.5,"AQ",PSOD)) Q:'PSOD F PSOP=0:0 S PSOP=$O(^PS(52.5,"AQ",PSOD,PSOP)) Q:'PSOP F PSOIN=0:0 S PSOIN=$O(^PS(52.5,"AQ",PSOD,PSOP,PSOIN)) Q:'PSOIN D
|
|
.I PSOD'=$P($G(^PS(52.5,PSOIN,0)),"^",2) K ^PS(52.5,"AQ",PSOD,PSOP,PSOIN)
|
|
MW ;Update routing field in Pending File
|
|
D BMES^XPDUTL("Updating routing field...")
|
|
N PAT,INST,PIEN,NODE,RELIN,PSOINZ
|
|
F PAT=0:0 S PAT=$O(^PS(52.41,"AOR",PAT)) Q:'PAT F INST=0:0 S INST=$O(^PS(52.41,"AOR",PAT,INST)) Q:'INST F PIEN=0:0 S PIEN=$O(^PS(52.41,"AOR",PAT,INST,PIEN)) Q:'PIEN S NODE=$G(^PS(52.41,PIEN,0)) I $P(NODE,"^",2),$P(NODE,"^",17)="" D
|
|
.S $P(^PS(52.41,PIEN,0),"^",17)="M"
|
|
.S ^PS(52.41,"AC",$P(NODE,"^",2),"M",PIEN)=""
|
|
;Updating Institution field
|
|
D BMES^XPDUTL("Updating Institution field...")
|
|
F PSOINZ=0:0 S PSOINZ=$O(^PS(59,PSOINZ)) Q:'PSOINZ S RELIN=$P($G(^PS(59,PSOINZ,"INI")),"^") I RELIN D
|
|
.I $O(^PS(59,PSOINZ,"INI1",0)) Q
|
|
.S ^PS(59,PSOINZ,"INI1",0)="^59.08P^1^1"
|
|
.S ^PS(59,PSOINZ,"INI1",1,0)=RELIN
|
|
.S ^PS(59,PSOINZ,"INI1","B",RELIN,1)=""
|
|
D BMES^XPDUTL("Indexing ACL cross reference...")
|
|
N PSODA,PSOPT,PSOPIN,PSONODE
|
|
F PSOPT=0:0 S PSOPT=$O(^PS(52.41,"AOR",PSOPT)) Q:'PSOPT F PSOPIN=0:0 S PSOPIN=$O(^PS(52.41,"AOR",PSOPT,PSOPIN)) Q:'PSOPIN F PSODA=0:0 S PSODA=$O(^PS(52.41,"AOR",PSOPT,PSOPIN,PSODA)) Q:'PSODA D
|
|
.S PSONODE=$G(^PS(52.41,PSODA,0))
|
|
.I $P(PSONODE,"^",3)=""!($P(PSONODE,"^",12)="")!($P(PSONODE,"^",13)="")!($P(PSONODE,"^",2)="") Q
|
|
.I $P(PSONODE,"^",3)'="NW",$P(PSONODE,"^",3)'="RNW",$P(PSONODE,"^",3)'="RF" Q
|
|
.S ^PS(52.41,"ACL",+$P(PSONODE,"^",13),+$P(PSONODE,"^",12),PSODA)=""
|
|
Q
|
|
IDNODE ; resets ^DD(52,0,"ID",6) node PSO*7*25
|
|
;
|
|
D BMES^XPDUTL("Resetting DD(52,0,""ID"",6) Node...")
|
|
S ^DD(52,0,"ID",6)="W:$D(^(0)) "" ""_$S($D(^PSDRUG(+$P(^(0),U,6),0))#2:$P(^(0),U,1),1:"""")_$E(^PSRX(+Y,0),0)_$S($P($G(^PSRX(+Y,""STA"")),U)=13:"" ***MARKED FOR DELETION***"",1:"""")"
|
|
K ^DD(55,0,"P"),^DD(55,0,"PS")
|
|
Q
|
|
PEND ;Delete invalid Renewal cross references
|
|
D BMES^XPDUTL("Updating 'AQ' cross reference...")
|
|
N PSOPN,PSOPNI
|
|
F PSOPN=0:0 S PSOPN=$O(^PS(52.41,"AQ",PSOPN)) Q:'PSOPN F PSOPNI=0:0 S PSOPNI=$O(^PS(52.41,"AQ",PSOPN,PSOPNI)) Q:'PSOPNI I $P($G(^PS(52.41,PSOPNI,0)),"^",3)="DC"!($P($G(^(0)),"^",3)="DE") K ^PS(52.41,"AQ",PSOPN,PSOPNI)
|
|
Q
|
|
SUBF ;hanging sub-file 59.30001 removal
|
|
S DIU=59.30001,DIU(0)="S" D:$D(^DD(DIU)) EN^DIU2 K DIU
|
|
Q
|