| [613] | 1 | PSOPOST3 ;BIR/SAB-index AD cross reference on login date field ;07/29/96
|
|---|
| 2 | ;;7.0;OUTPATIENT PHARMACY;**7,15,25,30,77**;DEC 1997
|
|---|
| 3 | ;
|
|---|
| 4 | ;Reference to ^DD(55,0,"P") and ^DD(55,0,"PS") is supported by IA #2752
|
|---|
| 5 | ;Reference to setting ^DD(52,0,"ID",6) supported by DBIA #2852
|
|---|
| 6 | ;Reference to DIU2 supported by DBIA #10014
|
|---|
| 7 | ;
|
|---|
| 8 | K ^PS(52.41,"AD")
|
|---|
| 9 | D BMES^XPDUTL("Indexing 'AD' cross reference...")
|
|---|
| 10 | 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
|
|---|
| 11 | .F DA=0:0 S DA=$O(^PS(52.41,"AOR",PAT,INST,DA)) Q:'DA D
|
|---|
| 12 | ..I '$P(^PS(52.41,DA,0),"^",12) D NOW^%DTC S $P(^PS(52.41,DA,0),"^",12)=%
|
|---|
| 13 | ..S DIK="^PS(52.41,",DIK(1)=15 D EN1^DIK W "."
|
|---|
| 14 | K PAT,INST,DA,DIK,DIC,X,Y,%,%H,%I
|
|---|
| 15 | Q
|
|---|
| 16 | SUS ;Deleting invalid "AQ" cross references
|
|---|
| 17 | ; Patch PSO*7*15 post init
|
|---|
| 18 | D BMES^XPDUTL("Indexing 'AQ' cross reference...")
|
|---|
| 19 | N PSOD,PSOP,PSOIN
|
|---|
| 20 | 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
|
|---|
| 21 | .I PSOD'=$P($G(^PS(52.5,PSOIN,0)),"^",2) K ^PS(52.5,"AQ",PSOD,PSOP,PSOIN)
|
|---|
| 22 | MW ;Update routing field in Pending File
|
|---|
| 23 | D BMES^XPDUTL("Updating routing field...")
|
|---|
| 24 | N PAT,INST,PIEN,NODE,RELIN,PSOINZ
|
|---|
| 25 | 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
|
|---|
| 26 | .S $P(^PS(52.41,PIEN,0),"^",17)="M"
|
|---|
| 27 | .S ^PS(52.41,"AC",$P(NODE,"^",2),"M",PIEN)=""
|
|---|
| 28 | ;Updating Institution field
|
|---|
| 29 | D BMES^XPDUTL("Updating Institution field...")
|
|---|
| 30 | F PSOINZ=0:0 S PSOINZ=$O(^PS(59,PSOINZ)) Q:'PSOINZ S RELIN=$P($G(^PS(59,PSOINZ,"INI")),"^") I RELIN D
|
|---|
| 31 | .I $O(^PS(59,PSOINZ,"INI1",0)) Q
|
|---|
| 32 | .S ^PS(59,PSOINZ,"INI1",0)="^59.08P^1^1"
|
|---|
| 33 | .S ^PS(59,PSOINZ,"INI1",1,0)=RELIN
|
|---|
| 34 | .S ^PS(59,PSOINZ,"INI1","B",RELIN,1)=""
|
|---|
| 35 | D BMES^XPDUTL("Indexing ACL cross reference...")
|
|---|
| 36 | N PSODA,PSOPT,PSOPIN,PSONODE
|
|---|
| 37 | 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
|
|---|
| 38 | .S PSONODE=$G(^PS(52.41,PSODA,0))
|
|---|
| 39 | .I $P(PSONODE,"^",3)=""!($P(PSONODE,"^",12)="")!($P(PSONODE,"^",13)="")!($P(PSONODE,"^",2)="") Q
|
|---|
| 40 | .I $P(PSONODE,"^",3)'="NW",$P(PSONODE,"^",3)'="RNW",$P(PSONODE,"^",3)'="RF" Q
|
|---|
| 41 | .S ^PS(52.41,"ACL",+$P(PSONODE,"^",13),+$P(PSONODE,"^",12),PSODA)=""
|
|---|
| 42 | Q
|
|---|
| 43 | IDNODE ; resets ^DD(52,0,"ID",6) node PSO*7*25
|
|---|
| 44 | ;
|
|---|
| 45 | D BMES^XPDUTL("Resetting DD(52,0,""ID"",6) Node...")
|
|---|
| 46 | 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:"""")"
|
|---|
| 47 | K ^DD(55,0,"P"),^DD(55,0,"PS")
|
|---|
| 48 | Q
|
|---|
| 49 | PEND ;Delete invalid Renewal cross references
|
|---|
| 50 | D BMES^XPDUTL("Updating 'AQ' cross reference...")
|
|---|
| 51 | N PSOPN,PSOPNI
|
|---|
| 52 | 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)
|
|---|
| 53 | Q
|
|---|
| 54 | SUBF ;hanging sub-file 59.30001 removal
|
|---|
| 55 | S DIU=59.30001,DIU(0)="S" D:$D(^DD(DIU)) EN^DIU2 K DIU
|
|---|
| 56 | Q
|
|---|
