PSSOAS ;BP/AGV - Old Schedule Name processing ;2/9/17
;;1.0;PHARMACY DATA MANAGEMENT;**201**;9/30/97;Build 25
;
; @Author - Alberto Vargas
; @Date - February 9, 2017
; @Version - 1.0
;
OASDIC ; screening for the OLD SCHEDULE NAME(S) multiple
N PSSDA,PSSX,PSSY,PSSFCHK,PSSFCHK2,PSSFCHK3,PSSFCHK4,PSSFL,PSSFL2,PSSFL3,PSSODA,PSSOX,PSSEX,PSSAIEN S PSSDA=$G(DA),PSSX=$G(X),PSSY=$G(Y),(PSSFL,PSSFL2,PSSFL3)=0,(PSSODA,PSSOX,PSSEX,PSSAIEN)=""
N DA,D0,X,Y,DIC,DIE,DIEL,DI,DC,DR,DQ,DL,DM,DK,DP,PSSRN,MSG
S DA=PSSDA,MSG=""
;
F S PSSRN=$$OASLE(DA),DA(1)=$G(DA) Q:'$G(DA(1)) S DIC="^PS(51.1,"_DA(1)_",5,",DIC(0)="AEMLTVZ",DIC("A")="Select OLD SCHEDULE NAME(S): "_$G(PSSRN) D ^DIC Q:+Y'>0 D
.I $G(X)["""" S X=$P($G(Y),U,2)
.S X=$$UP^XLFSTR(X)
.S PSSFCHK="" F S PSSFCHK=$O(^PS(51.1,"B",PSSFCHK)) Q:PSSFCHK']""!($G(PSSFL)) D
..I $G(PSSFCHK)=$G(X) S PSSFL=1
.I $G(PSSFL)=1,$P(Y,U,3)=1 SET PSSFL=0 K X D Q
..S DIE=DIC,DA=+Y,DR=".01////@" D ^DIE S DA=PSSDA
..S MSG(1)=""
..S MSG(2)=" An OLD SCHEDULE NAME(S) entry cannot be the same as an existing NAME"
..S MSG(3)=" field."
..S MSG(4)=""
..D EN^DDIOL(.MSG,"","!")
.S PSSODA=+Y
.S PSSOX=$P(Y,U,2)
.S DIR(0)="FAO^2:20",DIR("A")="OLD SCHEDULE NAME(S): "_PSSOX_"// " D ^DIR
.I $G(X)="^" S DA=PSSDA K X,DIR Q
.S X=$$UP^XLFSTR($G(X))
.I $G(X)=PSSOX S DA=PSSDA K X,DIR Q
.S PSSFCHK2="" F S PSSFCHK2=$O(^PS(51.1,"B",PSSFCHK2)) Q:PSSFCHK2']""!($G(PSSFL2)) D
..I $G(PSSFCHK2)=$G(X) S PSSFL2=1
.I $G(PSSFL2)=1 S PSSFL2=0 K X,DIR D Q
..S DA=PSSDA
..S MSG(1)=""
..S MSG(2)=" An OLD SCHEDULE NAME(S) entry cannot be the same as an existing NAME"
..S MSG(3)=" field."
..S MSG(4)=""
..D EN^DDIOL(.MSG,"","!")
.S PSSFCHK3="" F S PSSFCHK3=$O(^PS(51.1,$G(DA),5,PSSFCHK3)) Q:PSSFCHK3']""!($G(PSSFL3)) D
..I $G(^PS(51.1,$G(DA),5,PSSFCHK3,0))=$G(X) S PSSFL3=1
.I $G(PSSFL3)=1,$G(X)'="" S PSSFL3=0 K X,DIR D Q
..S DA=PSSDA
..S MSG(1)=""
..S MSG(2)=" Duplicate exists in Old Schedule Name multiple for this entry."
..S MSG(3)=""
..D EN^DDIOL(.MSG,"","!")
.I $G(PSSFL3)=1 S PSSFL3=0
.S PSSFCHK4="" F S PSSFCHK4=$O(^PS(51.1,"D",PSSFCHK4)) Q:PSSFCHK4']""!($G(PSSFL4)) D
..I $G(PSSFCHK4)=$G(X) S PSSFL4=1 F S PSSAIEN=$O(^PS(51.1,"D",PSSFCHK4,PSSAIEN)) Q:PSSAIEN'=""
.I $G(PSSFL4)=1 S PSSFL4=0 K X,DIR D Q
..S DA=PSSDA
..S MSG(1)=""
..S MSG(2)=" Duplicate exists in Old Schedule Name multiple for the entry"
..S MSG(3)=" "_$P(^PS(51.1,$G(PSSAIEN),0),U,1)_" ("_$G(PSSAIEN)_") in the file."
..S MSG(4)=""
..D EN^DDIOL(.MSG,"","!")
.I $G(X)'="",$G(X)'="@" S PSSEX=X,DIE=DIC,DA=PSSODA,DR=".01///^S X=PSSEX" D ^DIE S DA=PSSDA K DIR
.I $G(X)="@" S DIR(0)="YAO",DIR("A")="SURE YOU WANT TO DELETE? " D ^DIR
.I $G(Y)=1 S DIE=DIC,DA=PSSODA,DR=".01///@" D ^DIE S DA=PSSDA K DIR
.I $G(Y)=0 S DA=PSSDA K DIR
I $G(X)="^" K DIC,DIE,DR,DA Q
I $G(X)["^" D EN^DDIOL(" No Jumping allowed??","","!") K X,DIC,DIE,DR,DA Q
S X=PSSX,Y=PSSY K DIC,DIE,DR,DA,PSSDA,PSSX,PSSY Q
;
OASLE(PSSDA) ; retrieve the last entry from the OLD SCHEDULE NAME (#13) field multiple
N PSSLR,PSSLE S PSSLE=""
I $G(^PS(51.1,$G(PSSDA),5,0))'="" S PSSLR=999999 F S PSSLR=$O(^PS(51.1,$G(PSSDA),5,PSSLR),-1) S:$G(^PS(51.1,$G(PSSDA),5,PSSLR,0))'="" PSSLE=$G(^PS(51.1,$G(PSSDA),5,PSSLR,0))_"// " Q:PSSLR'=""
Q $G(PSSLE)
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSSOAS 3366 printed Sep 23, 2025@20:09:01 Page 2
PSSOAS ;BP/AGV - Old Schedule Name processing ;2/9/17
+1 ;;1.0;PHARMACY DATA MANAGEMENT;**201**;9/30/97;Build 25
+2 ;
+3 ; @Author - Alberto Vargas
+4 ; @Date - February 9, 2017
+5 ; @Version - 1.0
+6 ;
OASDIC ; screening for the OLD SCHEDULE NAME(S) multiple
+1 NEW PSSDA,PSSX,PSSY,PSSFCHK,PSSFCHK2,PSSFCHK3,PSSFCHK4,PSSFL,PSSFL2,PSSFL3,PSSODA,PSSOX,PSSEX,PSSAIEN
SET PSSDA=$GET(DA)
SET PSSX=$GET(X)
SET PSSY=$GET(Y)
SET (PSSFL,PSSFL2,PSSFL3)=0
SET (PSSODA,PSSOX,PSSEX,PSSAIEN)=""
+2 NEW DA,D0,X,Y,DIC,DIE,DIEL,DI,DC,DR,DQ,DL,DM,DK,DP,PSSRN,MSG
+3 SET DA=PSSDA
SET MSG=""
+4 ;
+5 FOR
SET PSSRN=$$OASLE(DA)
SET DA(1)=$GET(DA)
if '$GET(DA(1))
QUIT
SET DIC="^PS(51.1,"_DA(1)_",5,"
SET DIC(0)="AEMLTVZ"
SET DIC("A")="Select OLD SCHEDULE NAME(S): "_$GET(PSSRN)
DO ^DIC
if +Y'>0
QUIT
Begin DoDot:1
+6 IF $GET(X)[""""
SET X=$PIECE($GET(Y),U,2)
+7 SET X=$$UP^XLFSTR(X)
+8 SET PSSFCHK=""
FOR
SET PSSFCHK=$ORDER(^PS(51.1,"B",PSSFCHK))
if PSSFCHK']""!($GET(PSSFL))
QUIT
Begin DoDot:2
+9 IF $GET(PSSFCHK)=$GET(X)
SET PSSFL=1
End DoDot:2
+10 IF $GET(PSSFL)=1
IF $PIECE(Y,U,3)=1
SET PSSFL=0
KILL X
Begin DoDot:2
+11 SET DIE=DIC
SET DA=+Y
SET DR=".01////@"
DO ^DIE
SET DA=PSSDA
+12 SET MSG(1)=""
+13 SET MSG(2)=" An OLD SCHEDULE NAME(S) entry cannot be the same as an existing NAME"
+14 SET MSG(3)=" field."
+15 SET MSG(4)=""
+16 DO EN^DDIOL(.MSG,"","!")
End DoDot:2
QUIT
+17 SET PSSODA=+Y
+18 SET PSSOX=$PIECE(Y,U,2)
+19 SET DIR(0)="FAO^2:20"
SET DIR("A")="OLD SCHEDULE NAME(S): "_PSSOX_"// "
DO ^DIR
+20 IF $GET(X)="^"
SET DA=PSSDA
KILL X,DIR
QUIT
+21 SET X=$$UP^XLFSTR($GET(X))
+22 IF $GET(X)=PSSOX
SET DA=PSSDA
KILL X,DIR
QUIT
+23 SET PSSFCHK2=""
FOR
SET PSSFCHK2=$ORDER(^PS(51.1,"B",PSSFCHK2))
if PSSFCHK2']""!($GET(PSSFL2))
QUIT
Begin DoDot:2
+24 IF $GET(PSSFCHK2)=$GET(X)
SET PSSFL2=1
End DoDot:2
+25 IF $GET(PSSFL2)=1
SET PSSFL2=0
KILL X,DIR
Begin DoDot:2
+26 SET DA=PSSDA
+27 SET MSG(1)=""
+28 SET MSG(2)=" An OLD SCHEDULE NAME(S) entry cannot be the same as an existing NAME"
+29 SET MSG(3)=" field."
+30 SET MSG(4)=""
+31 DO EN^DDIOL(.MSG,"","!")
End DoDot:2
QUIT
+32 SET PSSFCHK3=""
FOR
SET PSSFCHK3=$ORDER(^PS(51.1,$GET(DA),5,PSSFCHK3))
if PSSFCHK3']""!($GET(PSSFL3))
QUIT
Begin DoDot:2
+33 IF $GET(^PS(51.1,$GET(DA),5,PSSFCHK3,0))=$GET(X)
SET PSSFL3=1
End DoDot:2
+34 IF $GET(PSSFL3)=1
IF $GET(X)'=""
SET PSSFL3=0
KILL X,DIR
Begin DoDot:2
+35 SET DA=PSSDA
+36 SET MSG(1)=""
+37 SET MSG(2)=" Duplicate exists in Old Schedule Name multiple for this entry."
+38 SET MSG(3)=""
+39 DO EN^DDIOL(.MSG,"","!")
End DoDot:2
QUIT
+40 IF $GET(PSSFL3)=1
SET PSSFL3=0
+41 SET PSSFCHK4=""
FOR
SET PSSFCHK4=$ORDER(^PS(51.1,"D",PSSFCHK4))
if PSSFCHK4']""!($GET(PSSFL4))
QUIT
Begin DoDot:2
+42 IF $GET(PSSFCHK4)=$GET(X)
SET PSSFL4=1
FOR
SET PSSAIEN=$ORDER(^PS(51.1,"D",PSSFCHK4,PSSAIEN))
if PSSAIEN'=""
QUIT
End DoDot:2
+43 IF $GET(PSSFL4)=1
SET PSSFL4=0
KILL X,DIR
Begin DoDot:2
+44 SET DA=PSSDA
+45 SET MSG(1)=""
+46 SET MSG(2)=" Duplicate exists in Old Schedule Name multiple for the entry"
+47 SET MSG(3)=" "_$PIECE(^PS(51.1,$GET(PSSAIEN),0),U,1)_" ("_$GET(PSSAIEN)_") in the file."
+48 SET MSG(4)=""
+49 DO EN^DDIOL(.MSG,"","!")
End DoDot:2
QUIT
+50 IF $GET(X)'=""
IF $GET(X)'="@"
SET PSSEX=X
SET DIE=DIC
SET DA=PSSODA
SET DR=".01///^S X=PSSEX"
DO ^DIE
SET DA=PSSDA
KILL DIR
+51 IF $GET(X)="@"
SET DIR(0)="YAO"
SET DIR("A")="SURE YOU WANT TO DELETE? "
DO ^DIR
+52 IF $GET(Y)=1
SET DIE=DIC
SET DA=PSSODA
SET DR=".01///@"
DO ^DIE
SET DA=PSSDA
KILL DIR
+53 IF $GET(Y)=0
SET DA=PSSDA
KILL DIR
End DoDot:1
+54 IF $GET(X)="^"
KILL DIC,DIE,DR,DA
QUIT
+55 IF $GET(X)["^"
DO EN^DDIOL(" No Jumping allowed??","","!")
KILL X,DIC,DIE,DR,DA
QUIT
+56 SET X=PSSX
SET Y=PSSY
KILL DIC,DIE,DR,DA,PSSDA,PSSX,PSSY
QUIT
+57 ;
OASLE(PSSDA) ; retrieve the last entry from the OLD SCHEDULE NAME (#13) field multiple
+1 NEW PSSLR,PSSLE
SET PSSLE=""
+2 IF $GET(^PS(51.1,$GET(PSSDA),5,0))'=""
SET PSSLR=999999
FOR
SET PSSLR=$ORDER(^PS(51.1,$GET(PSSDA),5,PSSLR),-1)
if $GET(^PS(51.1,$GET(PSSDA),5,PSSLR,0))'=""
SET PSSLE=$GET(^PS(51.1,$GET(PSSDA),5,PSSLR,0))_"// "
if PSSLR'=""
QUIT
+3 QUIT $GET(PSSLE)
