- 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 Feb 18, 2025@23:59:22 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)